Skip to content
Snippets Groups Projects
Commit 4bbab89d authored by Kevin M. Rosenberg's avatar Kevin M. Rosenberg
Browse files

Add support for square brackets around IPv6 addresses to

explicity show port number (thanks to Philipp Marek)
parent 5c3615ce
Branches master
No related tags found
No related merge requests found
cl-puri (1:1.5.7.2-1) unstable; urgency=medium
* Add support for square brackets around IPv6 addresses to
explicity show port number (thanks to Philipp Marek)
-- Kevin M. Rosenberg <kmr@debian.org> Tue, 29 Sep 2020 15:55:37 +0000
cl-puri (1:1.5.7.1-1) unstable; urgency=medium cl-puri (1:1.5.7.1-1) unstable; urgency=medium
* Rework test suite for newer versions of ASDF * Rework test suite for newer versions of ASDF
......
...@@ -34,6 +34,7 @@ ...@@ -34,6 +34,7 @@
#:uri-host #:uri-port #:uri-host #:uri-port
#:uri-path #:uri-path
#:uri-query #:uri-query
#:uri-is-ip6
#:uri-fragment #:uri-fragment
#:uri-plist #:uri-plist
#:uri-authority ; pseudo-slot accessor #:uri-authority ; pseudo-slot accessor
...@@ -238,6 +239,10 @@ ...@@ -238,6 +239,10 @@
:initarg :parsed-path :initarg :parsed-path
:initform nil :initform nil
:accessor .uri-parsed-path) :accessor .uri-parsed-path)
(is-ip6
:initarg :is-ip6
:initform nil
:accessor uri-is-ip6)
(hashcode (hashcode
;; cached sxhash, so we don't have to compute it more than once. ;; cached sxhash, so we don't have to compute it more than once.
:initarg :hashcode :initform nil :accessor uri-hashcode))) :initarg :hashcode :initform nil :accessor uri-hashcode)))
...@@ -362,7 +367,7 @@ ...@@ -362,7 +367,7 @@
#\Rubout ;; (code-char #x7f) #\Rubout ;; (code-char #x7f)
;; `unwise': ;; `unwise':
#\{ #\} #\| #\\ #\^ #\[ #\] #\`)) #\{ #\} #\| #\\ #\^ #\[ #\] #\`))
"Excluded charcters from RFC2369 (http://www.ietf.org/rfc/rfc2396.txt 2.4.3)") "Excluded charcters from RFC2396 (http://www.ietf.org/rfc/rfc2396.txt 2.4.3)")
(defun reserved-char-vector (chars &key except) (defun reserved-char-vector (chars &key except)
(do* ((a (make-array 128 :element-type 'bit :initial-element 0)) (do* ((a (make-array 128 :element-type 'bit :initial-element 0))
...@@ -421,19 +426,27 @@ ...@@ -421,19 +426,27 @@
(append *excluded-characters* '(#\& #\~ #\/ #\?)))) (append *excluded-characters* '(#\& #\~ #\/ #\?))))
(defparameter *illegal-characters* (defparameter *illegal-characters*
(reserved-char-vector (remove #\# *excluded-characters*))) (reserved-char-vector (set-difference *excluded-characters*
'(#\# #\[ #\]))))
(defparameter *strict-illegal-query-characters* (defparameter *strict-illegal-query-characters*
(reserved-char-vector (append '(#\?) (remove #\# *excluded-characters*)))) (reserved-char-vector (append '(#\?) (remove #\# *excluded-characters*))))
(defparameter *illegal-query-characters* (defparameter *illegal-query-characters*
(reserved-char-vector (reserved-char-vector
*excluded-characters* :except '(#\^ #\| #\#))) *excluded-characters* :except '(#\^ #\| #\#)))
(defparameter *valid-ip6-characters*
(reserved-char-vector
'#.(nconc (gen-char-range-list #\a #\f)
(gen-char-range-list #\A #\F)
(gen-char-range-list #\0 #\9)
'(#\: #\]))))
(defun parse-uri (thing &key (class 'uri) &aux escape) (defun parse-uri (thing &key (class 'uri) &aux escape)
(when (uri-p thing) (return-from parse-uri thing)) (when (uri-p thing) (return-from parse-uri thing))
(setq escape (escape-p thing)) (setq escape (escape-p thing))
(multiple-value-bind (scheme host port path query fragment) (multiple-value-bind (scheme host port path query fragment is-ip6)
(parse-uri-string thing) (parse-uri-string thing)
(when scheme (when scheme
(setq scheme (setq scheme
...@@ -481,6 +494,7 @@ ...@@ -481,6 +494,7 @@
(make-instance 'uri (make-instance 'uri
:scheme scheme :scheme scheme
:host host :host host
:is-ip6 is-ip6
:port port :port port
:path path :path path
:query query :query query
...@@ -490,6 +504,7 @@ ...@@ -490,6 +504,7 @@
(make-instance class (make-instance class
:scheme scheme :scheme scheme
:host host :host host
:is-ip6 is-ip6
:port port :port port
:path path :path path
:query query :query query
...@@ -514,6 +529,7 @@ ...@@ -514,6 +529,7 @@
;; simulating: ;; simulating:
;; ^(([^:/?#]+):)? ;; ^(([^:/?#]+):)?
;; (//([^/?#]*))? ;; (//([^/?#]*))?
;; May include a []-pair for ipv6
;; ([^?#]*) ;; ([^?#]*)
;; (\?([^#]*))? ;; (\?([^#]*))?
;; (#(.*))? ;; (#(.*))?
...@@ -523,6 +539,7 @@ ...@@ -523,6 +539,7 @@
(tokval nil) (tokval nil)
(scheme nil) (scheme nil)
(host nil) (host nil)
(is-ip6 nil)
(port nil) (port nil)
(path-components '()) (path-components '())
(query nil) (query nil)
...@@ -562,10 +579,14 @@ URI ~s contains illegal character ~s at position ~d." ...@@ -562,10 +579,14 @@ URI ~s contains illegal character ~s at position ~d."
(#\? (return :question)) (#\? (return :question))
(#\# (return :hash)))) (#\# (return :hash))))
(:query (case c (#\# (return :hash)))) (:query (case c (#\# (return :hash))))
(:ip6 (case c
(#\] (return :close-bracket))))
(:rest) (:rest)
(t (case c (t (case c
(#\: (return :colon)) (#\: (return :colon))
(#\? (return :question)) (#\? (return :question))
(#\[ (return :open-bracket))
(#\] (return :close-bracket))
(#\# (return :hash)) (#\# (return :hash))
(#\/ (return :slash))))) (#\/ (return :slash)))))
(incf start))) (incf start)))
...@@ -643,11 +664,20 @@ URI ~s contains illegal character ~s at position ~d." ...@@ -643,11 +664,20 @@ URI ~s contains illegal character ~s at position ~d."
(setq state 6)) (setq state 6))
(:end (push "/" path-components) (:end (push "/" path-components)
(setq state 9)))) (setq state 9))))
(66 ;; seen [<scheme>:]//[
(ecase (read-token :ip6 *valid-ip6-characters*)
(:string (setq host tokval)
(setq is-ip6 t)
(setq state 67))))
(67 ;; seen [<scheme>:]//[ip6]
(ecase (read-token t)
(:close-bracket (setq state 11))))
(4 ;; seen [<scheme>:]// (4 ;; seen [<scheme>:]//
(ecase (read-token t) (ecase (read-token t)
(:colon (failure)) (:colon (failure))
(:question (failure)) (:question (failure))
(:hash (failure)) (:hash (failure))
(:open-bracket (setq state 66))
(:slash (:slash
(if* (and (equalp "file" scheme) (if* (and (equalp "file" scheme)
(null host)) (null host))
...@@ -725,7 +755,7 @@ URI ~s contains illegal character ~s at position ~d." ...@@ -725,7 +755,7 @@ URI ~s contains illegal character ~s at position ~d."
(values (values
scheme host port scheme host port
(apply #'concatenate 'string (nreverse path-components)) (apply #'concatenate 'string (nreverse path-components))
query fragment))) query fragment is-ip6)))
;; URN parsing: ;; URN parsing:
(15 ;; seen urn:, read nid now (15 ;; seen urn:, read nid now
(case (read-token :colon *valid-nid-characters*) (case (read-token :colon *valid-nid-characters*)
...@@ -829,6 +859,7 @@ URI ~s contains illegal character ~s at position ~d." ...@@ -829,6 +859,7 @@ URI ~s contains illegal character ~s at position ~d."
(setf (uri-string uri) (setf (uri-string uri)
(let ((scheme (uri-scheme uri)) (let ((scheme (uri-scheme uri))
(host (uri-host uri)) (host (uri-host uri))
(is-ip6 (uri-is-ip6 uri))
(port (uri-port uri)) (port (uri-port uri))
(path (uri-path uri)) (path (uri-path uri))
(query (uri-query uri)) (query (uri-query uri))
...@@ -841,9 +872,11 @@ URI ~s contains illegal character ~s at position ~d." ...@@ -841,9 +872,11 @@ URI ~s contains illegal character ~s at position ~d."
*reserved-characters* escape)) *reserved-characters* escape))
(when scheme ":") (when scheme ":")
(when (or host (eq :file scheme)) "//") (when (or host (eq :file scheme)) "//")
(when is-ip6 "[")
(when host (when host
(encode-escaped-encoding (encode-escaped-encoding
host *reserved-authority-characters* escape)) host *reserved-authority-characters* escape))
(when is-ip6 "]")
(when port ":") (when port ":")
(when port (when port
#-allegro (format nil "~D" port) #-allegro (format nil "~D" port)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment