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.
- src/tests/uri-tests.lisp
uses code from:
- src/tests/iri-tests.lisp
use code from:
quri https://github.com/fukamachi/quri

81
src/gemini-viewer.lisp
View File

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

3
src/gemini/client.lisp
View File

@ -287,9 +287,10 @@
(defun request (host path &key
(query nil)
(port +gemini-default-port+)
(fragment nil)
(client-certificate 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+)))
(when query
(setf iri (strcat iri "?" (percent-encode query))))

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

@ -174,22 +174,26 @@
((null (uri:host parsed))
(let* ((absolute-path-p (string-starts-with-p "/" link-value))
(path (if absolute-path-p
link-value
(uri:path parsed)
(strcat (if original-path
(path-last-dir original-path)
"/")
link-value))))
(uri:path parsed)))))
(make-gemini-iri original-host
(uri:normalize-path path)
nil
original-port)))
:query (uri:query parsed)
:port original-port
:fragment (uri:fragment parsed))))
((null (uri:scheme parsed))
(strcat +gemini-scheme+ ":"
(to-s (uri:normalize-path parsed))))
(t
(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)
(subseq path 1)
path))
@ -202,6 +206,8 @@
actual-path)))
(when query
(setf iri (strcat iri "?" query)))
(when fragment
(setf iri (strcat iri "#" fragment)))
iri))
(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))
(:text t))
(defrule ipath (or ipath-abempty)
(defrule ipath (or ipath-abempty
ipath-absolute
ipath-noscheme
ipath-rootless
ipath-empty)
(:text t))
(defrule ipath-absolute (and "/" (or isegment-nz (* (and "/" isegment ))))
(defrule ipath-absolute (and "/" (? (and isegment-non-zero (* (and "/" isegment )))))
(:text t))
(defrule ipath-rootless (and isegment-non-zero (* (and "/" isegment )))
@ -180,25 +184,38 @@
(? ifragment))
(:function extract-fields-from-absolute-iri))
(defrule irelative-part (and iauthority-start
iauthority
(or ipath-abempty
ipath-absolute
ipath-noscheme
ipath-empty))
(:function (lambda (a) (list (second a)
(third a)))))
(defrule irelative-part (or (and iauthority-start
iauthority
ipath-abempty)
ipath-absolute
ipath-noscheme
ipath-empty))
(defun extract-fields-from-relative-iri (parsed)
(let ((authority (first (first parsed)))
(path (second (first parsed))))
(defun extract-fields-from-relative-iri-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))))
(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))
(:function extract-fields-from-relative-iri))

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

@ -53,7 +53,15 @@
("http://[dead:beef::]:111/foo/" .
("http" nil "[dead:beef::]" "111" "/foo/" nil nil))
("//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)
(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://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))
("http" .
(nil nil nil nil "http" nil nil))
("http://" .
("http" nil nil nil nil nil nil))
;; are these valid URI?
;; ("tel:+31-641044153" .
;; ("tel" nil nil "+31-641044153" nil nil))
;; ("http://" .
;; ("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))

47
src/uri-parser.lisp
View File

@ -111,10 +111,14 @@
(defrule path-abempty (* (and "/" segment))
(:text t))
(defrule path (or path-abempty)
(defrule path (or path-abempty
path-absolute
path-noscheme
path-rootless
path-empty)
(:text t))
(defrule path-absolute (and "/" (or segment-nz (* (and "/" segment ))))
(defrule path-absolute (and "/" (? (and segment-nz (* (and "/" segment )))))
(:text t))
(defrule path-rootless (and segment-non-zero (* (and "/" segment )))
@ -155,25 +159,38 @@
(? 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)))))
(defrule relative-part (or (and authority-start
authority
path-abempty)
path-absolute
path-noscheme
path-empty))
(defun extract-fields-from-relative-uri (parsed)
(let ((authority (first (first parsed)))
(path (second (first parsed))))
(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) ; query
(third parsed)))) ;fragment))))
(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))