diff --git a/LICENSES.org b/LICENSES.org index a34ec61..2f54550 100644 --- a/LICENSES.org +++ b/LICENSES.org @@ -353,3 +353,42 @@ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + + - src/tests/uri-tests.lisp + + uses code from: + + quri https://github.com/fukamachi/quri + + Licensed under the BSD 3-Clause License. + + Copyright 2020 fukamachi + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + 3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS + FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE + COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, + INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES + (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR + OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, + EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/gemini-viewer.lisp b/src/gemini-viewer.lisp index 22772d6..d2bd35a 100644 --- a/src/gemini-viewer.lisp +++ b/src/gemini-viewer.lisp @@ -365,16 +365,16 @@ (certificate nil) (certificate-key nil) (do-nothing-if-exists-in-db t)) - (let ((parsed-uri (quri:uri url))) + (let ((parsed-uri (ignore-errors (uri:uri-parse url)))) (maybe-initialize-metadata specials:*message-window*) (if (null parsed-uri) (ui:error-message (format nil (_ "Could not understand the address ~s") url)) - (let* ((host (quri:uri-host parsed-uri)) - (path (quri:uri-path parsed-uri)) - (query (quri:uri-query parsed-uri)) - (port (or (quri:uri-port parsed-uri) + (let* ((host (uri:uri-host parsed-uri)) + (path (uri:uri-path parsed-uri)) + (query (uri:uri-query parsed-uri)) + (port (or (uri:uri-port parsed-uri) gemini-client:+gemini-default-port+)) (actual-uri (gemini-parser:make-gemini-uri host path @@ -435,9 +435,9 @@ (flet ((on-input-complete (maybe-accepted) (when (ui::boolean-input-accepted-p maybe-accepted) (let ((new-url (gemini-parser:absolutize-link meta - (quri:uri-host parsed-uri) - (quri:uri-port parsed-uri) - (quri:uri-path parsed-uri)))) + (uri:uri-host parsed-uri) + (uri:uri-port parsed-uri) + (uri:uri-path parsed-uri)))) (db-utils:with-ready-database (:connect nil) (request new-url :certificate-key certificate-key diff --git a/src/gemini/gemini-parser.lisp b/src/gemini/gemini-parser.lisp index 74da8a8..6b87e4a 100644 --- a/src/gemini/gemini-parser.lisp +++ b/src/gemini/gemini-parser.lisp @@ -167,6 +167,28 @@ path (fs:parent-dir-path path))) +(defun absolutize-link (link-value original-host original-port original-path) + (let ((parsed (or (ignore-errors (uri:uri-parse link-value)) + (uri:make-uri nil nil nil nil link-value nil nil)))) + (cond + ((null (uri:uri-host parsed)) + (let* ((absolute-path-p (string-starts-with-p "/" link-value)) + (path (if absolute-path-p + link-value + (strcat (if original-path + (path-last-dir original-path) + "/") + link-value)))) + (make-gemini-uri original-host + (uri:normalize-path path) + nil + original-port))) + ((null (uri:uri-scheme parsed)) + (strcat +gemini-scheme+ ":" + (to-s (uri:normalize-path parsed)))) + (t + (to-s (uri:normalize-path parsed)))))) + (defun make-gemini-uri (host path &optional (query nil) (port +gemini-default-port+)) (let* ((actual-path (if (string-starts-with-p "/" path) (subseq path 1) @@ -182,91 +204,6 @@ (setf uri (strcat uri "?" query))) uri)) -(defgeneric normalize-path (object)) - -(defmethod normalize-path ((object null)) - nil) - -(defmethod normalize-path ((object string)) - (flet ((make-stack () - (make-instance 'stack:stack - :test-fn #'string=)) - (fill-input-stack (stack) - (loop - for segment in (remove-if #'string-empty-p - (reverse (split "/" object))) - do - (stack:stack-push stack segment)))) - (let* ((ends-with-separator-p (string-ends-with-p "/" object)) - (ends-with-dots nil) - (input-stack (make-stack)) - (output-stack (make-stack))) - (fill-input-stack input-stack) - (labels ((fill-output-buffer () - (when (not (stack:stack-empty-p input-stack)) - (let ((popped (stack:stack-pop input-stack))) - (cond - ((and (string= popped "..") - (not (stack:stack-empty-p output-stack)) - (not (stack:stack-empty-p input-stack))) - (stack:stack-pop output-stack)) - ((and (or (string= popped "..") - (string= popped ".")) - (stack:stack-empty-p input-stack)) - (setf ends-with-dots t)) - ((and (string/= popped ".") - (string/= popped "..")) - (stack:stack-push output-stack popped)))) - (fill-output-buffer))) - (output-stack->list () - (reverse (loop - for segment = (stack:stack-pop output-stack) - while segment - collect segment)))) - (fill-output-buffer) - (let* ((joinable (output-stack->list)) - (merged (if joinable - (if (or ends-with-separator-p - ends-with-dots) - (wrap-with (join-with-strings joinable "/") "/") - (strcat "/" (join-with-strings joinable "/"))) - "/"))) - (regex-replace-all "//" merged "")))))) - -(defmethod normalize-path ((object quri:uri)) - (let ((clean-path (normalize-path (quri:uri-path object))) - (copy (quri:copy-uri object))) - (when clean-path - (setf (quri:uri-path copy) clean-path)) - copy)) - -(defmethod to-s ((object quri:uri)) - (with-output-to-string (stream) - (quri:render-uri object stream))) - -(defun absolutize-link (link-value original-host original-port original-path) - (let ((parsed (quri:uri link-value))) - (cond - ((null parsed) - (error "Unparsable address")) - ((null (quri:uri-host parsed)) - (let* ((absolute-path-p (string-starts-with-p "/" link-value)) - (path (if absolute-path-p - link-value - (strcat (if original-path - (path-last-dir original-path) - "/") - link-value)))) - (make-gemini-uri original-host - (normalize-path path) - nil - original-port))) - ((null (quri:uri-scheme parsed)) - (strcat +gemini-scheme+ ":" - (to-s (normalize-path parsed)))) - (t - (to-s (normalize-path parsed)))))) - (defun sexp->links (parsed-gemini original-host original-port original-path) (loop for node in parsed-gemini when (html-utils:tag= :a node) collect (let ((link-value (html-utils:attribute-value (html-utils:find-attribute :href node)))) @@ -280,7 +217,7 @@ (defun gemini-link-uri-p (uri) (conditions:with-default-on-error (nil) (or (text-utils:string-starts-with-p +gemini-scheme+ uri) - (null (quri:uri-scheme (quri:uri uri)))))) + (null (uri:uri-scheme (uri:uri-parse uri)))))) (defclass gemini-page-theme () ((link-prefix-gemini @@ -443,8 +380,8 @@ (defun gemini-uri-p (maybe-uri) (conditions:with-default-on-error (nil) - (let ((parsed (quri:uri maybe-uri))) + (let ((parsed (uri:uri-parse maybe-uri))) (and parsed (string-equal +gemini-scheme+ - (quri:uri-scheme parsed)) - (quri:uri-host parsed))))) + (uri:uri-scheme parsed)) + (uri:uri-host parsed))))) diff --git a/src/package.lisp b/src/package.lisp index f6cadba..9eb5399 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -610,6 +610,30 @@ :stack-empty-p :do-stack-element)) +(defpackage :uri-parser + (:use + :cl + :alexandria + :esrap + :cl-ppcre + :text-utils) + (:nicknames :uri) + (:export + :uri + :copy-uri + :render-uri + :uri-p + :uri-parse + :uri-scheme + :uri-user-info + :uri-host + :uri-port + :uri-path + :uri-query + :uri-fragment + :normalize-path + :make-uri)) + (defpackage :x509 (:use :cl diff --git a/src/tests/gemini-parser-tests.lisp b/src/tests/gemini-parser-tests.lisp index 2d96544..1953a2b 100644 --- a/src/tests/gemini-parser-tests.lisp +++ b/src/tests/gemini-parser-tests.lisp @@ -18,13 +18,3 @@ (in-package :gemini-parser-tests) (defsuite gemini-parser-suite (all-suite)) - -(defun normalize (path expected) - (string= (gemini-parser::normalize-path path) - expected)) - -(deftest test-normalize-path (gemini-parser-suite) - (assert-true (normalize "/a/x" "/a/x")) - (assert-true (normalize "/a/../b/x" "/b/x")) - (assert-true (normalize "/a/../b/x/.." "/b/x/")) - (assert-true (normalize "/a/../b/x/." "/b/x/"))) diff --git a/src/tests/package.lisp b/src/tests/package.lisp index fa157e1..39129a1 100644 --- a/src/tests/package.lisp +++ b/src/tests/package.lisp @@ -39,6 +39,14 @@ :all-tests) (:export)) +(defpackage :uri-tests + (:use :cl + :alexandria + :clunit + :uri + :all-tests) + (:export)) + (defpackage :numeric-tests (:use :cl :clunit diff --git a/src/tests/program-events-tests.lisp b/src/tests/program-events-tests.lisp index a4a2191..8a9d2c8 100644 --- a/src/tests/program-events-tests.lisp +++ b/src/tests/program-events-tests.lisp @@ -64,6 +64,12 @@ (bt:join-thread main-thread) payload)) +(defclass dummy-window () ()) + +(defmethod (setf command-window:echo-character) (val (object dummy-window)) + t) + (deftest test-ask-input (program-events-suite) + (setf specials:*command-window* (make-instance 'dummy-window)) (assert-true (string= "foo" (dunbox (simulated-string-input))))) diff --git a/src/tests/uri-tests.lisp b/src/tests/uri-tests.lisp new file mode 100644 index 0000000..eaf2abb --- /dev/null +++ b/src/tests/uri-tests.lisp @@ -0,0 +1,79 @@ +;; tinmop: an humble gemini and pleroma client +;; Copyright (C) 2020 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")) + ;; are these vaild URI for rfc3986? + ;; ("http" . + ;; (nil nil nil "http" nil nil)) + ;; ("http:" . + ;; ("http" nil nil nil nil nil)) + ;; ("tel:+31-641044153" . + ;; ("tel" nil nil "+31-641044153" 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= (uri: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/x/")) + (assert-true (normalize "/a/../b/x/." "/b/x/"))) diff --git a/src/uri-parser.lisp b/src/uri-parser.lisp new file mode 100644 index 0000000..28f5982 --- /dev/null +++ b/src/uri-parser.lisp @@ -0,0 +1,361 @@ +;; tinmop: an humble gemini and pleroma client +;; Copyright (C) 2020 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) + +(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) + (:text t)) + +(defrule path-absolute (and "/" (or 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 (and authority-start + authority + (or path-abempty + path-absolute + path-noscheme + path-empty)) + (:function (lambda (a) (list (second a) + (third a))))) + +(defun extract-fields-from-relative-uri (parsed) + (let ((authority (first (first parsed))) + (path (second (first parsed)))) + (list nil ; scheme + (first authority) ; user-credentials + (second authority) ; host + (third authority) ; port + path + (second parsed) ; query + (third parsed)))) ;fragment)))) + +(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 () + ((uri-scheme + :initform nil + :initarg :scheme + :accessor uri-scheme) + (uri-user-info + :initform nil + :initarg :user-info + :accessor uri-user-info) + (uri-host + :initform nil + :initarg :host + :writer (setf uri-scheme)) + (uri-port + :initform nil + :initarg :port + :accessor uri-port) + (uri-path + :initform nil + :initarg :path + :accessor uri-path) + (uri-query + :initform nil + :initarg :query + :accessor uri-query) + (uri-fragment + :initform nil + :initarg :fragment + :accessor uri-fragment))) + +(defgeneric uri-host (object)) + +(defmethod uri-host ((object uri)) + (let ((host (slot-value object 'uri-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 (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))) + (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 (uri-scheme uri)) + (user-info (uri-user-info uri)) + (host (slot-value uri 'uri-host)) + (port (uri-port uri)) + (path (uri-path uri)) + (query (uri-query uri)) + (fragment (uri-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:uri-path object))) + (copy (uri:copy-uri object))) + (when clean-path + (setf (uri:uri-path copy) clean-path)) + copy)) + +(defgeneric normalize-path (object)) + +(defmethod normalize-path ((object null)) + nil) + +(defmethod normalize-path ((object string)) + (flet ((make-stack () + (make-instance 'stack:stack + :test-fn #'string=)) + (fill-input-stack (stack) + (loop + for segment in (remove-if #'string-empty-p + (reverse (split "/" object))) + do + (stack:stack-push stack segment)))) + (let* ((ends-with-separator-p (string-ends-with-p "/" object)) + (ends-with-dots nil) + (input-stack (make-stack)) + (output-stack (make-stack))) + (fill-input-stack input-stack) + (labels ((fill-output-buffer () + (when (not (stack:stack-empty-p input-stack)) + (let ((popped (stack:stack-pop input-stack))) + (cond + ((and (string= popped "..") + (not (stack:stack-empty-p output-stack)) + (not (stack:stack-empty-p input-stack))) + (stack:stack-pop output-stack)) + ((and (or (string= popped "..") + (string= popped ".")) + (stack:stack-empty-p input-stack)) + (setf ends-with-dots t)) + ((and (string/= popped ".") + (string/= popped "..")) + (stack:stack-push output-stack popped)))) + (fill-output-buffer))) + (output-stack->list () + (reverse (loop + for segment = (stack:stack-pop output-stack) + while segment + collect segment)))) + (fill-output-buffer) + (let* ((joinable (output-stack->list)) + (merged (if joinable + (if (or ends-with-separator-p + ends-with-dots) + (wrap-with (join-with-strings joinable "/") "/") + (strcat "/" (join-with-strings joinable "/"))) + "/"))) + (regex-replace-all "//" merged "")))))) + +(defmethod to-s ((object uri:uri)) + (with-output-to-string (stream) + (uri:render-uri object stream))) diff --git a/tinmop.asd b/tinmop.asd index d9fb95e..71122d5 100644 --- a/tinmop.asd +++ b/tinmop.asd @@ -49,7 +49,7 @@ :drakma :usocket :babel - :quri +; :quri :percent-encoding :uiop) :components ((:file "package") @@ -72,6 +72,7 @@ (:file "priority-queue") (:file "queue") (:file "stack") + (:file "uri-parser") (:file "x509-ffi") (:file "x509") (:file "api-pleroma-entities") @@ -126,6 +127,7 @@ (:file "all-tests") (:file "misc-tests") (:file "box-tests") + (:file "uri-tests") (:file "numeric-tests") (:file "text-utils-tests") (:file "mtree-tests")