diff --git a/LICENSES.org b/LICENSES.org index 2f54550..7fb9e98 100644 --- a/LICENSES.org +++ b/LICENSES.org @@ -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 diff --git a/src/gemini-viewer.lisp b/src/gemini-viewer.lisp index 88df9bf..8639143 100644 --- a/src/gemini-viewer.lisp +++ b/src/gemini-viewer.lisp @@ -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) diff --git a/src/gemini/client.lisp b/src/gemini/client.lisp index 9ff151c..0e18406 100644 --- a/src/gemini/client.lisp +++ b/src/gemini/client.lisp @@ -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)))) diff --git a/src/gemini/gemini-parser.lisp b/src/gemini/gemini-parser.lisp index 2449f47..4868df3 100644 --- a/src/gemini/gemini-parser.lisp +++ b/src/gemini/gemini-parser.lisp @@ -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) diff --git a/src/iri-parser.lisp b/src/iri-parser.lisp index 44b37e9..be20b5b 100644 --- a/src/iri-parser.lisp +++ b/src/iri-parser.lisp @@ -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)) diff --git a/src/tests/iri-tests.lisp b/src/tests/iri-tests.lisp index c04b111..117c29d 100644 --- a/src/tests/iri-tests.lisp +++ b/src/tests/iri-tests.lisp @@ -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 diff --git a/src/tests/uri-tests.lisp b/src/tests/uri-tests.lisp index eaf2abb..d5a0958 100644 --- a/src/tests/uri-tests.lisp +++ b/src/tests/uri-tests.lisp @@ -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)) diff --git a/src/uri-parser.lisp b/src/uri-parser.lisp index 34d8128..93054dc 100644 --- a/src/uri-parser.lisp +++ b/src/uri-parser.lisp @@ -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))