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

- adding user info in uri related functions.

This commit is contained in:
cage 2022-01-15 17:50:53 +01:00
parent 38b74b782b
commit 2dd2a738a7
2 changed files with 44 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
src/gemini/client.lisp
View File

@ -320,19 +320,22 @@
(port (or (uri:port iri) (port (or (uri:port iri)
+gemini-default-port+)) +gemini-default-port+))
(scheme (uri:scheme iri)) (scheme (uri:scheme iri))
(user-info (uri:user-info iri))
(actual-iri (gemini-parser:make-gemini-iri host (actual-iri (gemini-parser:make-gemini-iri host
path path
:query query :user-info user-info
:port port :query query
:fragment fragment :port port
:scheme scheme))) :fragment fragment
:scheme scheme)))
(values actual-iri (values actual-iri
host host
path path
query query
port port
fragment fragment
scheme))) scheme
user-info)))
(defun debug-gemini (&rest data) (defun debug-gemini (&rest data)
(declare (ignorable data)) (declare (ignorable data))
@ -474,19 +477,20 @@
(when-let* ((all-rows (db:find-tls-certificates-rows)) (when-let* ((all-rows (db:find-tls-certificates-rows))
(parsed-request-iri (iri:iri-parse request-iri :null-on-error t))) (parsed-request-iri (iri:iri-parse request-iri :null-on-error t)))
(multiple-value-bind (request-iri request-host request-path request-query request-port (multiple-value-bind (request-iri request-host request-path request-query request-port
request-fragment request-scheme) request-fragment request-scheme request-user-info)
(gemini-client:displace-iri parsed-request-iri) (gemini-client:displace-iri parsed-request-iri)
(declare (ignore request-iri request-query request-fragment)) (declare (ignore request-iri request-query request-fragment))
(loop for row in all-rows do (loop for row in all-rows do
(let ((id (db:row-id row))) (let ((id (db:row-id row)))
(multiple-value-bind (iri host path query port fragment scheme) (multiple-value-bind (iri host path query port fragment scheme user-info)
(gemini-client:displace-iri (iri:iri-parse (db:row-cache-key row))) (gemini-client:displace-iri (iri:iri-parse (db:row-cache-key row)))
(declare (ignore iri query fragment)) (declare (ignore iri query fragment))
(when (and (string= request-host host) (when (and (string= request-host host)
(string= request-scheme scheme) (string= request-scheme scheme)
(= request-port port) (string= request-user-info user-info)
(text-utils:string-starts-with-p (gemini-parser:path-last-dir path) (= request-port port)
request-path)) (text-utils:string-starts-with-p (gemini-parser:path-last-dir path)
request-path))
(return-from tls-cert-find (return-from tls-cert-find
(values (strcat (os-utils:cached-file-path (to-s id)) (values (strcat (os-utils:cached-file-path (to-s id))
fs:*directory-sep* os-utils:+ssl-cert-name+) fs:*directory-sep* os-utils:+ssl-cert-name+)

48
src/gemini/gemini-parser.lisp
View File

@ -288,27 +288,35 @@
(fragment nil) (fragment nil)
(scheme +gemini-scheme+) (scheme +gemini-scheme+)
(omit-default-port t) (omit-default-port t)
(default-port *omitted-port*)) (default-port *omitted-port*)
(let* ((actual-path (if (string-starts-with-p "/" path) (user-info nil))
(subseq path 1) (let* ((actual-path (if (string-starts-with-p "/" path)
path)) (subseq path 1)
(actual-port (cond path))
((null port) (actual-port (cond
"") ((null port)
((and omit-default-port "")
(= port default-port)) ((and omit-default-port
"") (= port default-port))
(t "")
(to-s port)))) (t
(domain-port-separator (if (string-not-empty-p actual-port) (to-s port))))
":" (domain-port-separator (if (string-not-empty-p actual-port)
"")) ":"
(actual-host (if (iri:ipv6-address-p host) ""))
(strcat "[" host "]") (actual-host (if (iri:ipv6-address-p host)
host)) (strcat "[" host "]")
host))
(actual-user-info (if (string-not-empty-p user-info)
user-info
""))
(user-info-host-separator (if (string-not-empty-p user-info)
"@"
""))
(iri (strcat scheme "://" (iri (strcat scheme "://"
actual-host domain-port-separator actual-user-info user-info-host-separator actual-host
actual-port "/" domain-port-separator actual-port "/"
actual-path))) actual-path)))
(when query (when query
(setf iri (strcat iri "?" query))) (setf iri (strcat iri "?" query)))