mirror of https://codeberg.org/cage/tinmop/
- [TITAN] prevented dropping of query component.
After discussing on IRC (thanks!) i think is legit (according to the specification) to have URL like that: titan://invalid/path/to/script;mime=text/plain;size=1;token=foo?query=bar
This commit is contained in:
parent
a7c4e36f09
commit
888a361d86
|
@ -749,8 +749,12 @@
|
|||
:certificate-key cached-key
|
||||
:certificate cached-certificate)))
|
||||
(titan-upload-dispatch (url)
|
||||
(declare (ignore url))
|
||||
(values titan-data titan-size titan-mime titan-token)))
|
||||
(let ((parsed (iri:iri-parse url)))
|
||||
(values (gemini-client::remove-titan-parameters-from-path (uri:path parsed))
|
||||
titan-data
|
||||
titan-size
|
||||
titan-mime
|
||||
titan-token))))
|
||||
(handler-case
|
||||
(gemini-client:with-request-dispatch-table ((:certificate-requested
|
||||
#'certificate-request-dispatch
|
||||
|
|
|
@ -476,7 +476,7 @@
|
|||
"received an unknown response from server ~s ~a ~s ~s"
|
||||
iri status code-description meta))))
|
||||
|
||||
(defun start-titan-request (url 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))
|
||||
(multiple-value-bind (actual-iri host path query port)
|
||||
(displace-iri (iri:iri-parse url))
|
||||
(declare (ignore actual-iri))
|
||||
|
@ -484,27 +484,28 @@
|
|||
((and mime-type size)
|
||||
(multiple-value-bind (status description meta response socket)
|
||||
(gemini-client:titan-request host
|
||||
path
|
||||
no-parameters-path
|
||||
mime-type
|
||||
size
|
||||
token
|
||||
data
|
||||
:query query
|
||||
:port port
|
||||
:certificate-key certificate-key
|
||||
:client-certificate certificate)
|
||||
(close-ssl-socket socket)
|
||||
(values status description meta response socket)))
|
||||
((null mime-type)
|
||||
(error "mime type not present in ~a" query))
|
||||
(error "mime type not present in ~a" path))
|
||||
((null size)
|
||||
(error "mime type not present or invalid in ~a" query)))))
|
||||
(error "mime type not present or invalid in ~a" path)))))
|
||||
|
||||
(defun request-dispatch (url manage-functions
|
||||
&key
|
||||
(certificate nil)
|
||||
(certificate-key nil))
|
||||
(flet ((make-titan-request ()
|
||||
(multiple-value-bind (titan-data size mime token)
|
||||
(multiple-value-bind (no-parameters-path titan-data size mime token)
|
||||
(funcall (getf manage-functions :titan-upload
|
||||
(lambda (url)
|
||||
(declare (ignore url))
|
||||
|
@ -514,6 +515,7 @@
|
|||
"No function to get titan data provided"))))
|
||||
url)
|
||||
(start-titan-request url
|
||||
no-parameters-path
|
||||
titan-data
|
||||
mime
|
||||
size
|
||||
|
|
|
@ -190,8 +190,8 @@
|
|||
:debug-gemini
|
||||
:open-tls-socket
|
||||
:request
|
||||
:make-titan-query
|
||||
:parse-titan-query
|
||||
:make-titan-parameters
|
||||
:parse-titan-parameters
|
||||
:titan-request
|
||||
:gemini-file-stream-p
|
||||
:text-file-stream-p
|
||||
|
|
|
@ -30,14 +30,20 @@
|
|||
|
||||
(define-constant +titan-records-separator+ ";" :test #'string=)
|
||||
|
||||
(defun make-titan-query (mime-type size token)
|
||||
(defun make-titan-parameters (mime-type size token)
|
||||
(format nil
|
||||
";~a~a~a~a~a~a~a~3*~@[~3:*~a~a~a~a~]"
|
||||
+titan-mime-key+ +titan-field-separator+ mime-type +titan-records-separator+
|
||||
+titan-size-key+ +titan-field-separator+ size +titan-records-separator+
|
||||
+titan-token-key+ +titan-field-separator+ token))
|
||||
|
||||
(defun parse-titan-query (query)
|
||||
(defun remove-titan-parameters-from-path (path)
|
||||
(subseq path
|
||||
0
|
||||
(position +titan-records-separator+ path
|
||||
:test (lambda (item char) (char= (first-elt item) char)))))
|
||||
|
||||
(defun parse-titan-parameters (path)
|
||||
(flet ((get-value (key)
|
||||
(multiple-value-bind (matchedp registers)
|
||||
(scan-to-strings (format nil
|
||||
|
@ -46,19 +52,21 @@
|
|||
+titan-field-separator+
|
||||
+titan-records-separator+
|
||||
+titan-records-separator+)
|
||||
query)
|
||||
path)
|
||||
(when matchedp
|
||||
(first-elt registers)))))
|
||||
(let ((raw-size (get-value +titan-size-key+)))
|
||||
(values (get-value +titan-mime-key+)
|
||||
(values (remove-titan-parameters-from-path path)
|
||||
(get-value +titan-mime-key+)
|
||||
(parse-integer raw-size)
|
||||
(get-value +titan-token-key+)))))
|
||||
|
||||
(defgeneric titan-request (host path mime-type size token data
|
||||
&key port fragment client-certificate certificate-key))
|
||||
&key query port fragment client-certificate certificate-key))
|
||||
|
||||
(defmethod titan-request (host path mime-type (size integer) token (data string)
|
||||
&key
|
||||
(query nil)
|
||||
(port +gemini-default-port+)
|
||||
(fragment nil)
|
||||
(client-certificate nil)
|
||||
|
@ -70,6 +78,7 @@
|
|||
size
|
||||
token
|
||||
stream
|
||||
:query query
|
||||
:port port
|
||||
:fragment fragment
|
||||
:client-certificate client-certificate
|
||||
|
@ -77,6 +86,7 @@
|
|||
|
||||
(defmethod titan-request (host path mime-type (size integer) token (data pathname)
|
||||
&key
|
||||
(query nil)
|
||||
(port +gemini-default-port+)
|
||||
(fragment nil)
|
||||
(client-certificate nil)
|
||||
|
@ -92,6 +102,7 @@
|
|||
size
|
||||
token
|
||||
stream
|
||||
:query query
|
||||
:port port
|
||||
:fragment fragment
|
||||
:client-certificate client-certificate
|
||||
|
@ -99,15 +110,17 @@
|
|||
|
||||
(defmethod titan-request (host path mime-type (size integer) token (data stream)
|
||||
&key
|
||||
(query nil)
|
||||
(port +gemini-default-port+)
|
||||
(fragment nil)
|
||||
(client-certificate nil)
|
||||
(certificate-key nil))
|
||||
(let* ((iri (make-gemini-iri (idn:host-unicode->ascii host)
|
||||
(strcat (percent-encode-path path)
|
||||
(make-titan-query mime-type
|
||||
(make-titan-parameters mime-type
|
||||
size
|
||||
token))
|
||||
:query query
|
||||
:scheme +titan-scheme+
|
||||
:port port
|
||||
:fragment (percent-encode-fragment fragment)))
|
||||
|
|
|
@ -76,8 +76,8 @@
|
|||
size (length trimmed-data-text)
|
||||
titan-data trimmed-data-text)))
|
||||
(when (not has-error-p)
|
||||
(let ((query (gemini-client:make-titan-query mime size (gui:text token-entry))))
|
||||
(setf (uri:query url) query)
|
||||
(let ((parameters (gemini-client:make-titan-parameters mime size (gui:text token-entry))))
|
||||
(setf (uri:path url) (strcat (uri:path url) parameters))
|
||||
(ev:with-enqueued-process-and-unblock ()
|
||||
(gui-goodies::with-notify-errors
|
||||
(gui-goodies:with-busy* (frame)
|
||||
|
|
|
@ -215,12 +215,12 @@
|
|||
:certificate-key cached-key
|
||||
:certificate cached-certificate)))
|
||||
(titan-upload-dispatch (url)
|
||||
(multiple-value-bind (mime size token)
|
||||
(gemini-client::parse-titan-query (uri:query (iri:iri-parse url)))
|
||||
(multiple-value-bind (no-parameters-path mime size token)
|
||||
(gemini-client::parse-titan-parameters (uri:path (iri:iri-parse url)))
|
||||
(let ((actual-data (if (fs:file-exists-p titan-data)
|
||||
(fs:namestring->pathname titan-data)
|
||||
titan-data)))
|
||||
(values actual-data size mime token)))))
|
||||
(values no-parameters-path actual-data size mime token)))))
|
||||
(handler-case
|
||||
(gemini-client:with-request-dispatch-table ((:certificate-requested
|
||||
#'certificate-request-dispatch
|
||||
|
|
Loading…
Reference in New Issue