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

- removed uri-parser

This commit is contained in:
cage 2024-06-29 14:22:05 +02:00
parent d043506a4f
commit 4ac967966b
21 changed files with 160 additions and 541 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/complete.lisp
View File

@ -220,11 +220,11 @@ list af all possible candidates for completion."
(defun maybe-remove-file-scheme (maybe-file-scheme-iri)
(let ((parsed-as-iri (iri:iri-parse maybe-file-scheme-iri :null-on-error t)))
(if (and parsed-as-iri
(string= (uri:scheme parsed-as-iri) constants:+file-scheme+)
(string= (iri:scheme parsed-as-iri) constants:+file-scheme+)
(and (text-utils:string-starts-with-p (text-utils:strcat constants:+file-scheme+
"://")
maybe-file-scheme-iri)))
(uri:path parsed-as-iri)
(iri:path parsed-as-iri)
maybe-file-scheme-iri)))
(defun expand-iri-as-local-path-p (hint)

2
src/gemini-viewer.lisp
View File

@ -789,7 +789,7 @@
:prompt error-message)))))))
(titan-upload-dispatch (url)
(let ((parsed (iri:iri-parse url)))
(values (gemini-client::remove-titan-parameters-from-path (uri:path parsed))
(values (gemini-client::remove-titan-parameters-from-path (iri:path parsed))
titan-data
titan-size
titan-mime

28
src/gemini/client.lisp
View File

@ -392,14 +392,14 @@
(maybe-percent-encode fragment))
(defun displace-iri (iri)
(let* ((host (uri:host iri))
(path (uri:path iri))
(query (uri:query iri))
(fragment (uri:fragment iri))
(port (or (uri:port iri)
(let* ((host (iri:host iri))
(path (iri:path iri))
(query (iri:query iri))
(fragment (iri:fragment iri))
(port (or (iri:port iri)
+gemini-default-port+))
(scheme (uri:scheme iri))
(user-info (uri:user-info iri))
(scheme (iri:scheme iri))
(user-info (iri:user-info iri))
(actual-iri (gemini-parser:make-gemini-iri host
path
:user-info user-info
@ -726,16 +726,16 @@
(when meta-url
(if (absolute-gemini-url-p meta)
meta
(let* ((meta-query (uri:query meta-url))
(meta-path (uri:path meta-url))
(let* ((meta-query (iri:query meta-url))
(meta-path (iri:path meta-url))
(meta-path-query (if meta-query
(strcat meta-path "?" meta-query)
meta-path))
(new-url (gemini-parser:absolutize-link meta-path-query
(uri:host iri-from)
(uri:port iri-from)
(uri:path iri-from)
(uri:query iri-from))))
(iri:host iri-from)
(iri:port iri-from)
(iri:path iri-from)
(iri:query iri-from))))
new-url)))))
(defmethod build-redirect-iri (meta (iri-from string))
@ -774,5 +774,5 @@ TODO: Add client certificate."
(defun url-needs-proxy-p (url)
(and (swconf:config-gemini-proxy)
(string= (uri:scheme (iri:iri-parse url))
(string= (iri:scheme (iri:iri-parse url))
+http-scheme+)))

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

@ -293,31 +293,31 @@
(normalize-path (strcat path-to-last-dir
fs:*directory-sep*
link-value)))))
((null (uri:host parsed))
((null (iri:host parsed))
(let* ((absolute-path-p (string-starts-with-p "/" link-value))
(query-path-p (uri:query parsed))
(query-path-p (iri:query parsed))
(path (cond
(absolute-path-p
(uri:path parsed))
(iri:path parsed))
((and query-path-p
original-query)
(strcat (safe-all-but-last-elt original-path)
(uri:path parsed)))
(iri:path parsed)))
((or query-path-p
original-query)
(strcat original-path
(uri:path parsed)))
(iri:path parsed)))
(t
(strcat (if original-path
(path-last-dir original-path)
"/")
(uri:path parsed))))))
(iri:path parsed))))))
(make-gemini-iri original-host
(fs:normalize-path path)
:query (uri:query parsed)
:query (iri:query parsed)
:port original-port
:fragment (uri:fragment parsed))))
((null (uri:scheme parsed))
:fragment (iri:fragment parsed))))
((null (iri:scheme parsed))
(strcat +gemini-scheme+ ":"
(to-s (fs:normalize-path parsed))))
(t
@ -393,7 +393,7 @@
(defun gemini-link-iri-p (iri)
(conditions:with-default-on-error (nil)
(or (text-utils:string-starts-with-p +gemini-scheme+ iri)
(null (uri:scheme (iri:iri-parse iri))))))
(null (iri:scheme (iri:iri-parse iri))))))
(defclass gemini-page-theme ()
((link-prefix-gemini
@ -908,8 +908,8 @@
(let ((parsed (iri:iri-parse maybe-iri)))
(and parsed
(string-equal +gemini-scheme+
(uri:scheme parsed))
(uri:host parsed)))))
(iri:scheme parsed))
(iri:host parsed)))))
(defgeneric gemini-first-h1 (data))

8
src/gemini/subscription.lisp
View File

@ -70,10 +70,10 @@ This function return the 'post-title' substring."
(gemlog-iri (iri:iri-parse url)))
(let ((links (remove-if-not (lambda (a) (link-post-timestamp-p (name a)))
(sexp->links parsed
(uri:host gemlog-iri)
(uri:port gemlog-iri)
(uri:path gemlog-iri)
(uri:query gemlog-iri))))
(iri:host gemlog-iri)
(iri:port gemlog-iri)
(iri:path gemlog-iri)
(iri:query gemlog-iri))))
(new-posts-count 0))
(loop for link in links do
(when (not (db:find-gemlog-entry (to-s (target link))))

28
src/gui/client/main-window.lisp
View File

@ -147,7 +147,7 @@
(print-info-message (_ "Stream finished"))
(gui:configure-mouse-pointer (gemtext-widget main-window) :xterm)
(render-toc main-window iri)
(a:when-let* ((fragment (uri:fragment (iri:iri-parse iri)))
(a:when-let* ((fragment (iri:fragment (iri:iri-parse iri)))
(regexp (gemini-viewer::fragment->regex fragment)))
(setf (gui:text (client-search-frame::entry (search-frame main-window)))
regexp)
@ -381,11 +381,11 @@
(defun remove-standard-port (iri)
(let ((copy (iri:copy-iri (iri:iri-parse iri))))
(when (and (uri:port copy)
(uri:host copy)
(= (uri:port copy)
(when (and (iri:port copy)
(iri:host copy)
(= (iri:port copy)
gemini-constants:+gemini-default-port+))
(setf (uri:port copy) nil))
(setf (iri:port copy) nil))
(to-s copy)))
(defun absolutize-link (request-iri link-value)
@ -475,7 +475,7 @@
(defun inline-image-p (link-value)
(a:when-let* ((parsed (iri:iri-parse link-value :null-on-error t))
(path (uri:path parsed)))
(path (iri:path parsed)))
(and (or (gemini-client:absolute-gemini-url-p link-value)
(not (iri:absolute-url-p link-value)))
(or (re:scan "(?i)jpg$" path)
@ -595,7 +595,7 @@ local file paths."
when (not (iri:absolute-url-p link-value))
do
(let ((parsed (iri:iri-parse (get-address-bar-text main-window))))
(setf (uri:path parsed)
(setf (iri:path parsed)
(fs:normalize-path link-value))
(enqueue-add-link-to-tour (with-output-to-string (stream)
(iri:render-iri parsed stream))
@ -1013,7 +1013,7 @@ local file paths."
(defun iri-ensure-path (iri)
(let ((parsed (iri:iri-parse iri :null-on-error t)))
(if (and parsed
(null (uri:path parsed)))
(null (iri:path parsed)))
(strcat iri "/")
iri)))
@ -1075,7 +1075,7 @@ local file paths."
(defun open-search-iri (criteria main-window)
(let ((parsed-iri-search-capsule (iri:iri-parse (swconf:config-gemini-search-engine-iri))))
(setf (uri:query parsed-iri-search-capsule)
(setf (iri:query parsed-iri-search-capsule)
(text-utils:maybe-percent-encode criteria))
(let ((search-iri (with-output-to-string (stream)
(iri:render-iri parsed-iri-search-capsule stream))))
@ -1090,8 +1090,8 @@ local file paths."
ev:+maximum-event-priority+
actual-iri)))
(cond
((string= (uri:scheme parsed-iri) +internal-scheme-view-source+)
(setf (uri:scheme parsed-iri) gemini-constants:+gemini-scheme+)
((string= (iri:scheme parsed-iri) +internal-scheme-view-source+)
(setf (iri:scheme parsed-iri) gemini-constants:+gemini-scheme+)
(start-stream-iri (iri-ensure-path (to-s parsed-iri))
main-window
use-cache
@ -1113,11 +1113,11 @@ local file paths."
:status status)
(client-stream-frame::refresh-all-streams
(client-stream-frame::table stream-frame))))
((or (null (uri:scheme parsed-iri))
(string= (uri:scheme parsed-iri)
((or (null (iri:scheme parsed-iri))
(string= (iri:scheme parsed-iri)
constants:+file-scheme+))
(initialize-ir-lines main-window)
(open-local-path (uri:path parsed-iri) main-window))
(open-local-path (iri:path parsed-iri) main-window))
(t
(client-os-utils:open-resource-with-external-program main-window actual-iri))))
(esrap:esrap-parse-error (e)

2
src/gui/client/menu-command.lisp
View File

@ -144,6 +144,6 @@
(lambda ()
(a:when-let ((iri (iri:iri-parse (client-main-window::get-address-bar-text main-window)
:null-on-error t)))
(setf (uri:scheme iri) +internal-scheme-view-source+)
(setf (iri:scheme iri) +internal-scheme-view-source+)
(client-main-window::set-address-bar-text main-window (to-s iri))
(client-main-window::open-iri (to-s iri) main-window nil))))

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

@ -77,7 +77,7 @@
titan-data trimmed-data-text)))
(when (not has-error-p)
(let ((parameters (gemini-client:make-titan-parameters mime size (gui:text token-entry))))
(setf (uri:path url) (strcat (uri:path url) parameters))
(setf (iri:path url) (strcat (iri:path url) parameters))
(gui-goodies:with-notify-errors
(ev:with-enqueued-process-and-unblock ()
(comm:make-request :titan-save-token
@ -121,7 +121,7 @@
(let* ((certificate-path meta)
(message (format nil
(_ "Provide the password to unlock certificate for ~a")
(uri:path url)))
(iri:path url)))
(password (gui-goodies::password-dialog (gui:root-toplevel)
(_ "Unlock certificate")
message))

2
src/gui/server/public-api-gemini-certificates.lisp
View File

@ -55,7 +55,7 @@
(declare (ignore x))
(if proxy-host
(db:tofu-delete proxy-host)
(let ((host (uri:host (iri:iri-parse iri))))
(let ((host (iri:host (iri:iri-parse iri))))
(db:tofu-delete host)))))
(defun gemini-import-certificate (uri cert-file key-file)

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

@ -247,7 +247,7 @@
iri))))))
(titan-upload-dispatch (url)
(multiple-value-bind (no-parameters-path mime size token)
(gemini-client::parse-titan-parameters (uri:path (iri:iri-parse url)))
(gemini-client::parse-titan-parameters (iri:path (iri:iri-parse url)))
(let ((actual-data (if (fs:file-exists-p titan-data)
(fs:namestring->pathname titan-data)
titan-data)))

2
src/html-utils.lisp
View File

@ -40,7 +40,7 @@
(defun http-link-iri-p (iri)
(conditions:with-default-on-error (nil)
(or (text-utils:string-starts-with-p +http-scheme+ iri)
(null (uri:scheme (iri:iri-parse iri))))))
(null (iri:scheme (iri:iri-parse iri))))))
(defun make-tag-node (tag attributes value)
"create a node"

137
src/iri-parser.lisp
View File

@ -252,19 +252,55 @@
(defrule iri-iri-reference (or iri-iri iri-irelative-ref))
(defclass iri (uri:uri) ())
(defclass iri ()
((scheme
:initform nil
:initarg :scheme
:accessor scheme)
(user-info
:initform nil
:initarg :user-info
:accessor user-info)
(host
:initform nil
:initarg :host
:writer (setf host))
(port
:initform nil
:initarg :port
:accessor port)
(path
:initform nil
:initarg :path
:accessor path)
(query
:initform nil
:initarg :query
:accessor query)
(fragment
:initform nil
:initarg :fragment
:accessor fragment)))
(defgeneric host (object))
(defmethod host ((object iri))
(let ((host (slot-value object 'host)))
(if (text-utils:string-starts-with-p "[" host)
(subseq host 1 (1- (length host)))
host)))
(defmethod print-object ((object iri) stream)
(print-unreadable-object (object stream)
(format stream
"~s ~s ~s ~s ~s ~s ~s"
(uri:scheme object)
(uri:user-info object)
(uri:host object)
(uri:port object)
(uri:path object)
(uri:query object)
(uri:fragment object))))
(iri:scheme object)
(iri:user-info object)
(iri:host object)
(iri:port object)
(iri:path object)
(iri:query object)
(iri:fragment object))))
(defun make-iri (&optional scheme user-info host port path query fragment)
(make-instance 'iri
@ -300,13 +336,13 @@
(error e)))))
(defun copy-iri (from)
(let ((scheme (uri:scheme from))
(user-info (uri:user-info from))
(host (slot-value from 'uri:host))
(port (uri:port from))
(path (uri:path from))
(query (uri:query from))
(fragment (uri:fragment from)))
(let ((scheme (iri:scheme from))
(user-info (iri:user-info from))
(host (slot-value from 'iri:host))
(port (iri:port from))
(path (iri:path from))
(query (iri:query from))
(fragment (iri:fragment from)))
(make-iri scheme
user-info
host
@ -319,33 +355,26 @@
(defmethod remove-fragment ((object iri))
(let ((copied (copy-iri object)))
(setf (uri:fragment copied) nil)
(setf (iri:fragment copied) nil)
copied))
(defmethod normalize-path ((object iri))
(let ((clean-path (fs:normalize-path (uri:path object)))
(let ((clean-path (fs:normalize-path (iri:path object)))
(copy (copy-iri object)))
(when clean-path
(setf (uri:path copy) clean-path))
copy))
(defmethod normalize-path ((object uri:uri))
(let ((clean-path (fs:normalize-path (uri:path object)))
(copy (uri:copy-uri object)))
(when clean-path
(setf (uri:path copy) clean-path))
(setf (iri:path copy) clean-path))
copy))
(defun render-iri (iri &optional (stream *standard-output*))
(flet ((render ()
(with-output-to-string (string-stream)
(let ((scheme (uri:scheme iri))
(user-info (uri:user-info iri))
(host (slot-value iri 'uri:host))
(port (uri:port iri))
(path (uri:path iri))
(query (uri:query iri))
(fragment (uri:fragment iri)))
(let ((scheme (iri:scheme iri))
(user-info (iri:user-info iri))
(host (slot-value iri 'iri:host))
(port (iri:port iri))
(path (iri:path iri))
(query (iri:query iri))
(fragment (iri:fragment iri)))
(when scheme
(format string-stream "~a:" scheme))
(when host
@ -372,13 +401,13 @@
(defun absolute-url-p (url)
(when-let ((iri (iri:iri-parse url :null-on-error t)))
(not (or (null (uri:scheme iri))
(null (uri:host iri))))))
(not (or (null (iri:scheme iri))
(null (iri:host iri))))))
(defun absolute-url-scheme-p (url expected-scheme)
(when-let ((parsed-iri (iri:iri-parse url :null-on-error t)))
(and (absolute-url-p url)
(string= (uri:scheme parsed-iri) expected-scheme))))
(string= (iri:scheme parsed-iri) expected-scheme))))
(defun ipv4-address-p (string)
(ignore-errors
@ -394,32 +423,32 @@
(defun iri-to-parent-path (iri)
(let* ((parsed-iri (iri:iri-parse iri))
(parent-path (fs:parent-dir-path (uri:path parsed-iri)))
(parent-path (fs:parent-dir-path (iri:path parsed-iri)))
(new-iri (to-s (make-instance 'iri:iri
:scheme (uri:scheme parsed-iri)
:host (uri:host parsed-iri)
:user-info (uri:user-info parsed-iri)
:port (uri:port parsed-iri)
:scheme (iri:scheme parsed-iri)
:host (iri:host parsed-iri)
:user-info (iri:user-info parsed-iri)
:port (iri:port parsed-iri)
:path parent-path))))
new-iri))
(defgeneric iri= (a b))
(defmethod iri= ((a iri) (b iri))
(let ((scheme-a (uri:scheme a))
(user-info-a (uri:user-info a))
(host-a (uri:host a))
(port-a (uri:port a))
(path-a (uri:path a))
(query-a (uri:query a))
(fragment-a (uri:fragment a))
(scheme-b (uri:scheme b))
(user-info-b (uri:user-info b))
(host-b (uri:host b))
(port-b (uri:port b))
(path-b (uri:path b))
(query-b (uri:query b))
(fragment-b (uri:fragment b)))
(let ((scheme-a (iri:scheme a))
(user-info-a (iri:user-info a))
(host-a (iri:host a))
(port-a (iri:port a))
(path-a (iri:path a))
(query-a (iri:query a))
(fragment-a (iri:fragment a))
(scheme-b (iri:scheme b))
(user-info-b (iri:user-info b))
(host-b (iri:host b))
(port-b (iri:port b))
(path-b (iri:path b))
(query-b (iri:query b))
(fragment-b (iri:fragment b)))
(and (string= scheme-a scheme-b)
(string= user-info-a user-info-b)
(string= host-a host-b)

8
src/open-message-link-window.lisp
View File

@ -79,17 +79,17 @@
(defun parse-fediverse-virtual-iri (iri)
(let ((parsed-iri (iri:iri-parse iri)))
(if (string= (uri:scheme parsed-iri)
(if (string= (iri:scheme parsed-iri)
+internal-scheme-local-posts+)
(values (uri:host parsed-iri)
(text-utils:trim-blanks (uri:path parsed-iri)
(values (iri:host parsed-iri)
(text-utils:trim-blanks (iri:path parsed-iri)
'(#\/)))
(error (_ "address ~a is not a valid virtual path for posts (timeline/folder)")
iri))))
(defun fediverse-virtual-iri-p (iri)
(let ((parsed-iri (iri:iri-parse iri)))
(string= (uri:scheme parsed-iri)
(string= (iri:scheme parsed-iri)
+internal-scheme-local-posts+)))
(defun open-message-link (url enqueue)

7
src/package.lisp
View File

@ -799,6 +799,13 @@
(:export
:+segment-separator+
:iri
:scheme
:user-info
:host
:port
:path
:query
:fragment
:copy-iri
:render-iri
:make-iri

10
src/program-events.lisp
View File

@ -1405,7 +1405,7 @@
(local-links (remove-if (lambda (link)
(let ((target (gemini-parser:target link)))
(if target
(uri:scheme (iri:iri-parse target))
(iri:scheme (iri:iri-parse target))
t)))
links))
(event (make-instance 'gemini-display-data-page
@ -1640,10 +1640,10 @@
(url (iri:iri-parse gemlog-url))
(parsed (gemini-parser:parse-gemini-file gemini-page :initialize-parser t))
(links (gemini-parser:sexp->links parsed
(uri:host url)
(uri:port url)
(uri:path url)
(uri:query url)))
(iri:host url)
(iri:port url)
(iri:path url)
(iri:query url)))
(theme gemini-client:*gemini-page-theme*))
(gemini-viewer:maybe-initialize-metadata specials:*message-window*)
(refresh-gemini-message-window links

4
src/software-configuration.lisp
View File

@ -1691,8 +1691,8 @@
+key-proxy+
+key-uri+))
(parsed-iri (iri:iri-parse iri :null-on-error t)))
(values (uri:host parsed-iri)
(uri:port parsed-iri))))
(values (iri:host parsed-iri)
(iri:port parsed-iri))))
(defun config-gemini-search-engine-iri ()
(let ((iri (access:accesses *software-configuration*

8
src/tests/package.lisp
View File

@ -39,14 +39,6 @@
:all-tests)
(:export))
(defpackage :uri-tests
(:use :cl
:alexandria
:clunit
:uri
:all-tests)
(:export))
(defpackage :iri-tests
(:use :cl
:alexandria

77
src/tests/uri-tests.lisp
View File

@ -1,77 +0,0 @@
;; tinmop: a multiprotocol client
;; Copyright © cage
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program.
;; If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].
(in-package :uri-tests)
(defsuite uri-suite (all-suite))
(defun test-uri (uri results)
(multiple-value-bind (x parsed)
(uri-parse uri)
(declare (ignore x))
(tree-equal (mapcar #'text-utils:to-s parsed) results :test #'string=)))
(defparameter *test-cases*
'(("file:///tmp/junk.txt" .
("file" nil nil nil "/tmp/junk.txt" nil nil))
("imap://mail.common-lisp.net/mbox1" .
("imap" nil "mail.common-lisp.net" nil "/mbox1" nil nil))
("mms://wms.sys.hinet.net/cts/Drama/09006251100.asf" .
("mms" nil "wms.sys.hinet.net" nil "/cts/Drama/09006251100.asf" nil nil))
("nfs://server/path/to/file.txt" .
("nfs" nil "server" nil "/path/to/file.txt" nil nil))
("svn+ssh://svn.zope.org/repos/main/ZConfig/trunk/" .
("svn+ssh" nil "svn.zope.org" nil "/repos/main/ZConfig/trunk/" nil nil))
("git+ssh://git@github.com/user/project.git" .
("git+ssh" "git" "github.com" nil "/user/project.git" nil nil))
("http://common-lisp.net" .
("http" nil "common-lisp.net" nil nil nil nil))
("http://common-lisp.net#abc" .
("http" nil "common-lisp.net" nil nil nil "abc"))
("http://common-lisp.net?q=abc" .
("http" nil "common-lisp.net" nil nil "q=abc" nil))
("http://common-lisp.net/#abc" .
("http" nil "common-lisp.net" nil "/" nil "abc"))
("http://a/b/c/d;p?q#f" .
("http" nil "a" nil "/b/c/d;p" "q" "f"))
("http" .
(nil nil nil nil "http" nil nil))
("http://" .
("http" nil nil nil nil nil nil))
;; ("http:" .
;; ("http" nil nil nil nil nil))
("ldap://[2001:db8::7]/c=GB?objectClass?one" .
("ldap" nil "[2001:db8::7]" nil "/c=GB" "objectClass?one" nil))
("http://[dead:beef::]:111/foo/" .
("http" nil "[dead:beef::]" "111" "/foo/" nil nil))
("//foo.bar:198/".
(NIL NIL "foo.bar" "198" "/" NIL NIL))))
(deftest test-parsing (uri-suite)
(loop for (a . b) in *test-cases* do
(assert-true (test-uri a b) a)))
(defun normalize (path expected)
(string= (fs:normalize-path path)
expected))
(deftest test-normalize-path (uri-suite)
(assert-true (normalize "/a/x" "/a/x"))
(assert-true (normalize "/a/../b/x" "/b/x"))
(assert-true (normalize "/a/../b/x/.." "/b/"))
(assert-true (normalize "/a/../b/x/." "/b/x/"))
(assert-true (normalize "/a/b/c/./../../g" "/a/g")))

12
src/ui-goodies.lisp
View File

@ -1584,7 +1584,7 @@ displayed using the standard image viewer installed on the system."
(or (gemini-parser:name uri)
(when-let* ((parsed (iri:iri-parse (gemini-parser:target uri)
:null-on-error t))
(path (and parsed (uri:path parsed))))
(path (and parsed (iri:path parsed))))
(fs:path-last-element path)))))
(files (loop for ct from 0 below images-count
collect
@ -1673,10 +1673,10 @@ Browse and optionally open the links the text of the message window contains."
(iri:absolute-url-p uri))
uri
(gemini-parser:absolutize-link uri
(uri:host current-url)
(uri:port current-url)
(uri:path current-url)
(uri:query current-url)))))
(iri:host current-url)
(iri:port current-url)
(iri:path current-url)
(iri:query current-url)))))
(open-message-link-window:open-message-link absolute-uri nil)))))
(defun open-previous-link ()
@ -3096,7 +3096,7 @@ printed, on the main window."
(defun init-kami-window (url handlers)
(if handlers
(let* ((path (uri:path (iri:iri-parse url)))
(let* ((path (iri:path (iri:iri-parse url)))
(path-to-dir-p (fs:path-referencing-dir-p path))
(init-path (if path-to-dir-p
path

330
src/uri-parser.lisp
View File

@ -1,330 +0,0 @@
;; tinmop: a multiprotocol client
;; Copyright © cage
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program.
;; If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].
(in-package :uri-parser)
;; NOTE: the parser is broken, use :iri-parser, instead
(define-constant +segment-separator+ "/" :test #'string=)
(defrule alpha (character-ranges (#\a #\z) (#\A #\Z))
(:text t))
(defrule digit (character-ranges (#\0 #\9))
(:text t))
(defrule scheme-delim #\:
(:constant :scheme-delim))
(defrule query-delim #\?
(:constant :query-delim))
(defrule fragment-delim #\#
(:constant :fragment-delim))
(defrule port-delim #\:
(:constant :port-delim))
(defrule credential-delim #\@
(:constant :credential-delim))
(defrule authority-start "//"
(:constant :authority-start))
(defrule sub-delims (or #\! #\$ #\& #\' #\( #\) #\* #\+ #\, #\; #\=)
(:text t))
(defrule gen-delims (or ":" "?" "#" "[" "]" "@" "")
(:text t))
(defrule unreserved-chars (or alpha digit #\- #\. #\_ #\~)
(:text t))
(defrule reserved-chars (or gen-delims sub-delims)
(:text t))
(defrule scheme (and alpha (* (or alpha digit "+" "-" "." )))
(:text t))
(defrule hier-part (and authority-start authority)
(:function second))
(defrule user-credentials (and userinfo credential-delim)
(:function first))
(defrule port-block (and port-delim port)
(:function second)
(:function parse-integer))
(defrule authority (and (? user-credentials)
host
(? port-block)))
(defrule reg-name (* (or unreserved-chars pct-encoded sub-delims ))
(:text t))
(defrule host (or ipv4-address ip-literal reg-name)
(:text t))
(defrule port (+ digit)
(:text t))
(defrule userinfo (* (or unreserved-chars pct-encoded sub-delims ":" ))
(:text t))
(defrule pct-encoded (and "%" hexdig hexdig)
(:text t))
(defrule hexdig (or (character-ranges #\a #\f) digit)
(:text t))
(defrule ipv4-address (and dec-octet "." dec-octet "." dec-octet "." dec-octet)
(:text t))
(defrule ip-literal (and "["
(+ (not (or "[" "]")))
"]")
(:text t))
(defrule pchar (or unreserved-chars pct-encoded sub-delims ":" "@")
(:text t))
(defrule segment (* pchar)
(:text t))
(defrule segment-non-zero (+ pchar)
(:text t))
(defrule segment-nz-nc (+ (or unreserved-chars pct-encoded sub-delims "@" ))
(:text t))
(defrule path-abempty (* (and "/" segment))
(:text t))
(defrule path (or path-abempty
path-absolute
path-noscheme
path-rootless
path-empty)
(:text t))
(defrule path-absolute (and "/" (? (and segment-nz (* (and "/" segment )))))
(:text t))
(defrule path-rootless (and segment-non-zero (* (and "/" segment )))
(:text t))
(defrule path-noscheme (and segment-nz-nc (* (and "/" segment )))
(:text t))
(defrule path-empty ""
(:constant nil))
(defun octect-p (maybe-octect)
(ignore-errors
(let ((number (parse-integer (text-utils:strcat* maybe-octect))))
(when (<= 0 number 255)
number))))
(defrule dec-octet (octect-p (+ digit))
(:text t))
(defun extract-fields-from-absolute-uri (parsed)
(let ((authority (third parsed)))
(list (first parsed) ; scheme
(first authority) ; user-credentials
(second authority) ; host
(third authority) ; port
(fourth parsed) ; path
(fifth parsed) ; query
(sixth parsed)))) ; fragment
(defrule uri (and scheme ":"
hier-part
(or path-abempty
path-absolute
path-noscheme
path-empty)
(? query)
(? fragment))
(:function extract-fields-from-absolute-uri))
(defrule relative-part (or (and authority-start
authority
path-abempty)
path-absolute
path-noscheme
path-empty))
(defun extract-fields-from-relative-uri-w-authority (parsed)
;; ((:IAUTHORITY-START (NIL "bar.baz" NIL) "/foo.gmi") "a=b" "afrag")
(let ((authority (second (first parsed)))
(path (third (first parsed))))
(list nil ; scheme
(first authority) ; user-credentials
(second authority) ; host
(third authority) ; port
path
(second parsed) ; iquery
(third parsed)))) ; fragment
(defun extract-fields-from-relative-uri-w/o-authority (parsed)
(list nil ; scheme
nil ; user-credentials
nil ; host
nil ; port
(first parsed) ; path
(second parsed) ; iquery
(third parsed))) ; fragment
(defun extract-fields-from-relative-uri (parsed)
(if (consp (first parsed))
(extract-fields-from-relative-uri-w-authority parsed)
(extract-fields-from-relative-uri-w/o-authority parsed)))
(defrule relative-ref (and relative-part (? query) (? fragment))
(:function extract-fields-from-relative-uri))
(defrule query (and query-delim (* (or pchar "/" "?")))
(:function second)
(:text t))
(defrule fragment (and fragment-delim (* (or pchar "/" "?")))
(:function second)
(:text t))
(defrule uri-reference (or uri relative-ref))
(defclass uri ()
((scheme
:initform nil
:initarg :scheme
:accessor scheme)
(user-info
:initform nil
:initarg :user-info
:accessor user-info)
(host
:initform nil
:initarg :host
:writer (setf host))
(port
:initform nil
:initarg :port
:accessor port)
(path
:initform nil
:initarg :path
:accessor path)
(query
:initform nil
:initarg :query
:accessor query)
(fragment
:initform nil
:initarg :fragment
:accessor fragment)))
(defgeneric host (object))
(defmethod host ((object uri))
(let ((host (slot-value object 'host)))
(if (text-utils:string-starts-with-p "[" host)
(subseq host 1 (1- (length host)))
host)))
(defun make-uri (&optional scheme user-info host port path query fragment)
(make-instance 'uri
:scheme scheme
:user-info user-info
:host host
:port port
:path path
:query query
:fragment fragment))
(defun uri-parse (uri)
(let* ((parsed (parse 'uri-reference uri :junk-allowed nil))
(res (mapcar (lambda (a) (cond
((typep a 'string)
(if (text-utils:string-empty-p a)
nil
a))
(t a)))
(list (first parsed) ; scheme
(second parsed) ; user-credentials
(third parsed) ; host
(fourth parsed) ; port
(fifth parsed) ; path
(sixth parsed) ; query
(seventh parsed))))) ; fragment
(values (apply #'make-uri res)
res)))
(defun copy-uri (from)
(let ((scheme (scheme from))
(user-info (user-info from))
(host (slot-value from 'host))
(port (port from))
(path (path from))
(query (query from))
(fragment (fragment from)))
(make-uri scheme
user-info
host
port
path
query
fragment)))
(defun render-uri (uri &optional (stream *standard-output*))
(flet ((render ()
(with-output-to-string (string-stream)
(let ((scheme (scheme uri))
(user-info (user-info uri))
(host (slot-value uri 'host))
(port (port uri))
(path (path uri))
(query (query uri))
(fragment (fragment uri)))
(when scheme
(format string-stream "~a:" scheme))
(write-string "//" string-stream)
(when user-info
(format string-stream "~a@" user-info))
(when host
(format string-stream "~a" host))
(when port
(format string-stream ":~a" port))
(when path
(format string-stream "~a" path))
(when query
(format string-stream "?~a" query))
(when fragment
(format string-stream "#~a" fragment))))))
(write-string (render) stream)))
(defmethod normalize-path ((object uri:uri))
(let ((clean-path (normalize-path (uri:path object)))
(copy (uri:copy-uri object)))
(when clean-path
(setf (uri:path copy) clean-path))
copy))
(defmethod to-s ((object uri:uri) &key &allow-other-keys)
(with-output-to-string (stream)
(uri:render-uri object stream)))

2
tinmop.asd
View File

@ -82,7 +82,6 @@
(:file "priority-queue")
(:file "queue")
(:file "stack")
(:file "uri-parser")
(:file "iri-parser")
(:file "tour-mode-parser")
(:file "x509-ffi")
@ -187,7 +186,6 @@
(:file "all-tests")
(:file "misc-tests")
(:file "box-tests")
(:file "uri-tests")
(:file "iri-tests")
(:file "numeric-tests")
(:file "text-utils-tests")