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

- fixed IRI and URI parser; 

- taken into account fragment of IRI;
- added more IRI and URI test;
- passes all the client tests.
This commit is contained in:
cage 2020-12-25 15:03:39 +01:00
parent d0c9ea0d70
commit 9fd958d12b
8 changed files with 151 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
LICENSES.org
View File

@ -355,8 +355,8 @@
WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
- src/tests/uri-tests.lisp - src/tests/uri-tests.lisp
- src/tests/iri-tests.lisp
uses code from: use code from:
quri https://github.com/fukamachi/quri quri https://github.com/fukamachi/quri

81
src/gemini-viewer.lisp
View File

@ -131,6 +131,14 @@
:initform nil :initform nil
:initarg :path :initarg :path
:accessor path) :accessor path)
(query
:initform nil
:initarg :query
:accessor query)
(fragment
:initform nil
:initarg :fragment
:accessor fragment)
(host (host
:initform nil :initform nil
:initarg :host :initarg :host
@ -178,7 +186,7 @@
(defgeneric downloading-allowed-p (object)) (defgeneric downloading-allowed-p (object))
(defgeneric downloading-start-thread (object function host port path query)) (defgeneric downloading-start-thread (object function host port path query fragment))
(defmethod abort-downloading ((object gemini-stream)) (defmethod abort-downloading ((object gemini-stream))
(with-accessors ((download-thread-lock download-thread-lock)) object (with-accessors ((download-thread-lock download-thread-lock)) object
@ -209,7 +217,11 @@
(defmethod downloading-start-thread ((object gemini-stream) (defmethod downloading-start-thread ((object gemini-stream)
function function
host port path query) host
port
path
query
fragment)
(with-accessors ((start-time start-time) (with-accessors ((start-time start-time)
(thread thread) (thread thread)
(stream-status stream-status) (stream-status stream-status)
@ -217,7 +229,11 @@
(setf thread (setf thread
(bt:make-thread function)) (bt:make-thread function))
(setf start-time (db-utils:local-time-obj-now)) (setf start-time (db-utils:local-time-obj-now))
(setf download-iri (gemini-parser:make-gemini-iri host path query port)) (setf download-iri (gemini-parser:make-gemini-iri host
path
:query query
:port port
:fragment fragment))
object)) object))
(defclass gemini-file-stream (gemini-stream) ()) (defclass gemini-file-stream (gemini-stream) ())
@ -281,7 +297,7 @@
:append-text append-text)))) :append-text append-text))))
(defun request-stream-gemini-document-thread (wrapper-object host (defun request-stream-gemini-document-thread (wrapper-object host
port path query) port path query fragment)
(with-accessors ((download-socket download-socket) (with-accessors ((download-socket download-socket)
(download-stream download-stream) (download-stream download-stream)
(octect-count octect-count) (octect-count octect-count)
@ -291,7 +307,11 @@
(program-events:push-event line-event)))) (program-events:push-event line-event))))
(lambda () (lambda ()
(with-open-support-file (file-stream support-file character) (with-open-support-file (file-stream support-file character)
(let* ((url (gemini-parser:make-gemini-iri host path query port)) (let* ((url (gemini-parser:make-gemini-iri host
path
:query query
:port port
:fragment fragment))
(url-header (format nil "-> ~a~%" url)) (url-header (format nil "-> ~a~%" url))
(parsed-url (gemini-parser:parse-gemini-file url-header)) (parsed-url (gemini-parser:parse-gemini-file url-header))
(url-response (gemini-client:make-gemini-file-response nil (url-response (gemini-client:make-gemini-file-response nil
@ -339,9 +359,12 @@
port port
path path
query query
status-code status-code-description meta) fragment
status-code
status-code-description
meta)
(declare (ignorable host (declare (ignorable host
port path query port path query fragment
status-code status-code-description meta)) status-code status-code-description meta))
(with-accessors ((download-socket download-socket) (with-accessors ((download-socket download-socket)
(download-stream download-stream) (download-stream download-stream)
@ -368,20 +391,23 @@
(%fill-buffer)))))) (%fill-buffer))))))
(defun displace-iri (iri) (defun displace-iri (iri)
(let* ((host (uri:host iri)) (let* ((host (uri:host iri))
(path (uri:path iri)) (path (uri:path iri))
(query (uri:query iri)) (query (uri:query iri))
(fragment (uri:fragment iri))
(port (or (uri:port iri) (port (or (uri:port iri)
gemini-client:+gemini-default-port+)) gemini-client:+gemini-default-port+))
(actual-iri (gemini-parser:make-gemini-iri host (actual-iri (gemini-parser:make-gemini-iri host
path path
query :query query
port))) :port port
:fragment fragment)))
(values actual-iri (values actual-iri
host host
path path
query query
port))) port
fragment)))
(defun request (url &key (defun request (url &key
(enqueue nil) (enqueue nil)
@ -397,21 +423,22 @@
(_ "Could not understand the address ~s") (_ "Could not understand the address ~s")
url))) url)))
(use-cached-file-if-exists (use-cached-file-if-exists
(multiple-value-bind (actual-iri host path query port) (multiple-value-bind (actual-iri host path query port fragment)
(displace-iri parsed-iri) (displace-iri parsed-iri)
(if (find-db-stream-url actual-iri) (if (find-db-stream-url actual-iri)
(gemini-viewer:db-entry-to-foreground actual-iri) (gemini-viewer:db-entry-to-foreground actual-iri)
(request (gemini-parser:make-gemini-iri host (request (gemini-parser:make-gemini-iri host
path path
query :query query
port) :port port
:fragment fragment)
:certificate-key certificate-key :certificate-key certificate-key
:certificate certificate :certificate certificate
:use-cached-file-if-exists nil :use-cached-file-if-exists nil
:do-nothing-if-exists-in-db :do-nothing-if-exists-in-db
do-nothing-if-exists-in-db)))) do-nothing-if-exists-in-db))))
(t (t
(multiple-value-bind (actual-iri host path query port) (multiple-value-bind (actual-iri host path query port fragment)
(displace-iri parsed-iri) (displace-iri parsed-iri)
(when (not (and do-nothing-if-exists-in-db (when (not (and do-nothing-if-exists-in-db
(find-db-stream-url actual-iri))) (find-db-stream-url actual-iri)))
@ -445,8 +472,9 @@
(db-utils:with-ready-database (:connect nil) (db-utils:with-ready-database (:connect nil)
(request (gemini-parser:make-gemini-iri host (request (gemini-parser:make-gemini-iri host
path path
input :query input
port) :port port
:fragment fragment)
:certificate-key certificate-key :certificate-key certificate-key
:certificate certificate))))) :certificate certificate)))))
(ui:ask-string-input #'on-input-complete (ui:ask-string-input #'on-input-complete
@ -461,7 +489,8 @@
:certificate-key certificate-key :certificate-key certificate-key
:client-certificate certificate :client-certificate certificate
:query query :query query
:port port) :port port
:fragment fragment)
(add-url-to-history specials:*message-window* actual-iri) (add-url-to-history specials:*message-window* actual-iri)
(cond (cond
((gemini-client:response-redirect-p status) ((gemini-client:response-redirect-p status)
@ -500,6 +529,8 @@
:host host :host host
:port port :port port
:path path :path path
:query query
:fragment fragment
:meta meta :meta meta
:status-code status :status-code status
:status-code-description :status-code-description
@ -512,7 +543,8 @@
host host
port port
path path
query)) query
fragment))
(enqueue-event (make-instance 'program-events:gemini-enqueue-download-event (enqueue-event (make-instance 'program-events:gemini-enqueue-download-event
:payload gemini-stream))) :payload gemini-stream)))
(program-events:push-event enqueue-event) (program-events:push-event enqueue-event)
@ -521,7 +553,8 @@
host host
port port
path path
query)) query
fragment))
(let* ((starting-status (starting-status meta)) (let* ((starting-status (starting-status meta))
(gemini-stream (make-instance 'gemini-others-data-stream (gemini-stream (make-instance 'gemini-others-data-stream
:stream-status starting-status :stream-status starting-status
@ -534,6 +567,7 @@
port port
path path
query query
fragment
status status
code-description code-description
meta)) meta))
@ -545,7 +579,8 @@
host host
port port
path path
query))))))) query
fragment)))))))
(gemini-client:gemini-tofu-error (e) (gemini-client:gemini-tofu-error (e)
(let ((host (gemini-client:host e))) (let ((host (gemini-client:host e)))
(flet ((on-input-complete (maybe-accepted) (flet ((on-input-complete (maybe-accepted)

3
src/gemini/client.lisp
View File

@ -287,9 +287,10 @@
(defun request (host path &key (defun request (host path &key
(query nil) (query nil)
(port +gemini-default-port+) (port +gemini-default-port+)
(fragment nil)
(client-certificate nil) (client-certificate nil)
(certificate-key nil)) (certificate-key nil))
(let* ((iri (make-gemini-iri host path query port)) (let* ((iri (make-gemini-iri host path :query query :port port :fragment fragment))
(ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+))) (ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+)))
(when query (when query
(setf iri (strcat iri "?" (percent-encode query)))) (setf iri (strcat iri "?" (percent-encode query))))

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

@ -174,22 +174,26 @@
((null (uri:host parsed)) ((null (uri:host parsed))
(let* ((absolute-path-p (string-starts-with-p "/" link-value)) (let* ((absolute-path-p (string-starts-with-p "/" link-value))
(path (if absolute-path-p (path (if absolute-path-p
link-value (uri:path parsed)
(strcat (if original-path (strcat (if original-path
(path-last-dir original-path) (path-last-dir original-path)
"/") "/")
link-value)))) (uri:path parsed)))))
(make-gemini-iri original-host (make-gemini-iri original-host
(uri:normalize-path path) (uri:normalize-path path)
nil :query (uri:query parsed)
original-port))) :port original-port
:fragment (uri:fragment parsed))))
((null (uri:scheme parsed)) ((null (uri:scheme parsed))
(strcat +gemini-scheme+ ":" (strcat +gemini-scheme+ ":"
(to-s (uri:normalize-path parsed)))) (to-s (uri:normalize-path parsed))))
(t (t
(to-s (uri:normalize-path parsed)))))) (to-s (uri:normalize-path parsed))))))
(defun make-gemini-iri (host path &optional (query nil) (port +gemini-default-port+)) (defun make-gemini-iri (host path &key
(query nil)
(port +gemini-default-port+)
(fragment nil))
(let* ((actual-path (if (string-starts-with-p "/" path) (let* ((actual-path (if (string-starts-with-p "/" path)
(subseq path 1) (subseq path 1)
path)) path))
@ -202,6 +206,8 @@
actual-path))) actual-path)))
(when query (when query
(setf iri (strcat iri "?" query))) (setf iri (strcat iri "?" query)))
(when fragment
(setf iri (strcat iri "#" fragment)))
iri)) iri))
(defun sexp->links (parsed-gemini original-host original-port original-path) (defun sexp->links (parsed-gemini original-host original-port original-path)

45
src/iri-parser.lisp
View File

@ -136,10 +136,14 @@
(defrule ipath-abempty (* (and "/" isegment)) (defrule ipath-abempty (* (and "/" isegment))
(:text t)) (:text t))
(defrule ipath (or ipath-abempty) (defrule ipath (or ipath-abempty
ipath-absolute
ipath-noscheme
ipath-rootless
ipath-empty)
(:text t)) (:text t))
(defrule ipath-absolute (and "/" (or isegment-nz (* (and "/" isegment )))) (defrule ipath-absolute (and "/" (? (and isegment-non-zero (* (and "/" isegment )))))
(:text t)) (:text t))
(defrule ipath-rootless (and isegment-non-zero (* (and "/" isegment ))) (defrule ipath-rootless (and isegment-non-zero (* (and "/" isegment )))
@ -180,25 +184,38 @@
(? ifragment)) (? ifragment))
(:function extract-fields-from-absolute-iri)) (:function extract-fields-from-absolute-iri))
(defrule irelative-part (and iauthority-start (defrule irelative-part (or (and iauthority-start
iauthority iauthority
(or ipath-abempty ipath-abempty)
ipath-absolute ipath-absolute
ipath-noscheme ipath-noscheme
ipath-empty)) ipath-empty))
(:function (lambda (a) (list (second a)
(third a)))))
(defun extract-fields-from-relative-iri (parsed) (defun extract-fields-from-relative-iri-w-authority (parsed)
(let ((authority (first (first parsed))) ;; ((:IAUTHORITY-START (NIL "bar.baz" NIL) "/foo.gmi") "a=b" "afrag")
(path (second (first parsed)))) (let ((authority (second (first parsed)))
(path (third (first parsed))))
(list nil ; scheme (list nil ; scheme
(first authority) ; user-credentials (first authority) ; user-credentials
(second authority) ; host (second authority) ; host
(third authority) ; port (third authority) ; port
path path
(second parsed) ; iquery (second parsed) ; iquery
(third parsed)))) ;fragment)))) (third parsed)))) ; fragment
(defun extract-fields-from-relative-iri-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-iri (parsed)
(if (consp (first parsed))
(extract-fields-from-relative-iri-w-authority parsed)
(extract-fields-from-relative-iri-w/o-authority parsed)))
(defrule irelative-ref (and irelative-part (? iquery) (? ifragment)) (defrule irelative-ref (and irelative-part (? iquery) (? ifragment))
(:function extract-fields-from-relative-iri)) (:function extract-fields-from-relative-iri))

10
src/tests/iri-tests.lisp
View File

@ -53,7 +53,15 @@
("http://[dead:beef::]:111/foo/" . ("http://[dead:beef::]:111/foo/" .
("http" nil "[dead:beef::]" "111" "/foo/" nil nil)) ("http" nil "[dead:beef::]" "111" "/foo/" nil nil))
("//foo.bar:198/". ("//foo.bar:198/".
(NIL NIL "foo.bar" "198" "/" NIL NIL)))) (nil nil "foo.bar" "198" "/" nil nil))
("//fo°o.bar:198/baz.gmi?a=b&b=c#a-fragment".
(nil nil "fo°o.bar" "198" "/baz.gmi" "a=b&b=c" "a-fragment"))
("/bar/baz/baz.gmi?a=b&b=c#a-fràgment".
(nil nil nil nil "/bar/baz/baz.gmi" "a=b&b=c" "a-fràgment"))
("http://" .
("http" nil nil nil nil nil nil))
("http" .
(nil nil nil nil "http" nil nil))))
(deftest test-parsing (iri-suite) (deftest test-parsing (iri-suite)
(loop for (a . b) in *test-cases* do (loop for (a . b) in *test-cases* do

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

@ -48,14 +48,14 @@
("http" nil "common-lisp.net" nil "/" nil "abc")) ("http" nil "common-lisp.net" nil "/" nil "abc"))
("http://a/b/c/d;p?q#f" . ("http://a/b/c/d;p?q#f" .
("http" nil "a" nil "/b/c/d;p" "q" "f")) ("http" nil "a" nil "/b/c/d;p" "q" "f"))
;; are these vaild URI for rfc3986? ("http" .
;; ("http" . (nil nil nil nil "http" nil nil))
;; (nil nil nil "http" nil nil)) ("http://" .
;; ("http:" . ("http" nil nil nil nil nil nil))
;; ("http" nil nil nil nil nil)) ;; are these valid URI?
;; ("tel:+31-641044153" . ;; ("tel:+31-641044153" .
;; ("tel" nil nil "+31-641044153" nil nil)) ;; ("tel" nil nil "+31-641044153" nil nil))
;; ("http://" . ;; ("http:" .
;; ("http" nil nil nil nil nil)) ;; ("http" nil nil nil nil nil))
("ldap://[2001:db8::7]/c=GB?objectClass?one" . ("ldap://[2001:db8::7]/c=GB?objectClass?one" .
("ldap" nil "[2001:db8::7]" nil "/c=GB" "objectClass?one" nil)) ("ldap" nil "[2001:db8::7]" nil "/c=GB" "objectClass?one" nil))

47
src/uri-parser.lisp
View File

@ -111,10 +111,14 @@
(defrule path-abempty (* (and "/" segment)) (defrule path-abempty (* (and "/" segment))
(:text t)) (:text t))
(defrule path (or path-abempty) (defrule path (or path-abempty
path-absolute
path-noscheme
path-rootless
path-empty)
(:text t)) (:text t))
(defrule path-absolute (and "/" (or segment-nz (* (and "/" segment )))) (defrule path-absolute (and "/" (? (and segment-nz (* (and "/" segment )))))
(:text t)) (:text t))
(defrule path-rootless (and segment-non-zero (* (and "/" segment ))) (defrule path-rootless (and segment-non-zero (* (and "/" segment )))
@ -155,25 +159,38 @@
(? fragment)) (? fragment))
(:function extract-fields-from-absolute-uri)) (:function extract-fields-from-absolute-uri))
(defrule relative-part (and authority-start (defrule relative-part (or (and authority-start
authority authority
(or path-abempty path-abempty)
path-absolute path-absolute
path-noscheme path-noscheme
path-empty)) path-empty))
(:function (lambda (a) (list (second a)
(third a)))))
(defun extract-fields-from-relative-uri (parsed) (defun extract-fields-from-relative-uri-w-authority (parsed)
(let ((authority (first (first parsed))) ;; ((:IAUTHORITY-START (NIL "bar.baz" NIL) "/foo.gmi") "a=b" "afrag")
(path (second (first parsed)))) (let ((authority (second (first parsed)))
(path (third (first parsed))))
(list nil ; scheme (list nil ; scheme
(first authority) ; user-credentials (first authority) ; user-credentials
(second authority) ; host (second authority) ; host
(third authority) ; port (third authority) ; port
path path
(second parsed) ; query (second parsed) ; iquery
(third parsed)))) ;fragment)))) (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)) (defrule relative-ref (and relative-part (? query) (? fragment))
(:function extract-fields-from-relative-uri)) (:function extract-fields-from-relative-uri))