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

- replaced quri with an internal parser; 

- [gemini] the client passes the torture test again;

- fixed event test.
This commit is contained in:
cage 2020-10-25 19:58:05 +01:00
parent 1ef820062a
commit 664e8212ce
10 changed files with 554 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
LICENSES.org
View File

@ -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.

16
src/gemini-viewer.lisp
View File

@ -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

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

@ -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)))))

24
src/package.lisp
View File

@ -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

10
src/tests/gemini-parser-tests.lisp
View File

@ -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/")))

8
src/tests/package.lisp
View File

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

6
src/tests/program-events-tests.lisp
View File

@ -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)))))

79
src/tests/uri-tests.lisp Normal file
View File

@ -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/")))

361
src/uri-parser.lisp Normal file
View File

@ -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)))

4
tinmop.asd
View File

@ -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")