From f5176bf4c8e05069d5ef1040df8489f686f73ac2 Mon Sep 17 00:00:00 2001 From: Olof-Joachim Frahm Date: Fri, 14 Jun 2013 23:20:09 +0200 Subject: [PATCH] Include IDNA to support international domain names. --- puri.asd | 2 +- src.lisp | 40 ++++++++++++++++++++++++++++++++-------- tests.lisp | 18 ++++++++++++++++++ 3 files changed, 51 insertions(+), 9 deletions(-) diff --git a/puri.asd b/puri.asd index 5c12ad6..22879b0 100644 --- a/puri.asd +++ b/puri.asd @@ -12,7 +12,7 @@ :maintainer "Kevin M. Rosenberg " :licence "GNU Lesser General Public License" :description "Portable Universal Resource Indentifier Library" - :depends-on (#:babel) + :depends-on (#:babel #:idna) :components ((:file "src"))) diff --git a/src.lisp b/src.lisp index 48a4543..9209ba7 100644 --- a/src.lisp +++ b/src.lisp @@ -25,7 +25,7 @@ ;; $Id$ (defpackage #:puri - (:use #:cl) + (:use #:cl #:idna) #-allegro (:nicknames #:net.uri) (:export #:uri ; the type and a function @@ -49,6 +49,7 @@ #:merge-uris #:enough-uri #:uri-parsed-path + #:uri-parsed-host #:render-uri #:make-uri-space ; interning... @@ -240,15 +241,23 @@ :initarg :parsed-path :initform nil :accessor .uri-parsed-path) + (parsed-host + :initarg :parsed-host + :initform nil + :accessor .uri-parsed-host) (hashcode ;; cached sxhash, so we don't have to compute it more than once. :initarg :hashcode :initform nil :accessor uri-hashcode))) (defmethod initialize-instance :after ((uri puri:uri) &key &allow-other-keys) - (let ((parsed-path (puri:uri-parsed-path uri))) + (let ((parsed-path (puri:uri-parsed-path uri)) + (parsed-host (puri:uri-parsed-host uri))) (when parsed-path (setf (puri:uri-parsed-path uri) - parsed-path)))) + parsed-path)) + (when parsed-host + (setf (puri:uri-parsed-host uri) + parsed-host)))) (defclass urn (uri) ((nid :initarg :nid :initform nil :accessor urn-nid) @@ -261,11 +270,11 @@ (prog1 (call-next-method) (setf (uri-string self) nil) ,@(when (eq name 'uri-path) `((setf (.uri-parsed-path self) nil))) + ,@(when (eq name 'uri-host) `((setf (.uri-parsed-host self) nil))) (setf (uri-hashcode self) nil)))) ) (clear-caching-on-slot-change uri-scheme) -(clear-caching-on-slot-change uri-host) (clear-caching-on-slot-change uri-port) (clear-caching-on-slot-change uri-path) (clear-caching-on-slot-change uri-query) @@ -277,6 +286,7 @@ `(make-instance ',(class-name (class-of self)) :scheme ,(uri-scheme self) :host ,(uri-host self) + :parsed-host ',(.uri-parsed-host self) :port ,(uri-port self) :path ',(uri-path self) :query ,(uri-query self) @@ -292,6 +302,8 @@ &key place (scheme (when uri (uri-scheme uri))) (host (when uri (uri-host uri))) + (parsed-host + (when uri (copy-seq (.uri-parsed-host uri)))) (port (when uri (uri-port uri))) (path (when uri (uri-path uri))) (parsed-path @@ -304,6 +316,7 @@ (if* place then (setf (uri-scheme place) scheme) (setf (uri-host place) host) + (setf (.uri-parsed-host place) parsed-host) (setf (uri-port place) port) (setf (uri-path place) path) (setf (.uri-parsed-path place) parsed-path) @@ -318,12 +331,12 @@ then ;; allow the compiler to optimize the call to make-instance: (make-instance 'uri :scheme scheme :host host :port port :path path - :parsed-path parsed-path + :parsed-path parsed-path :parsed-host parsed-host :query query :fragment fragment :plist plist :escaped escaped :string nil :hashcode nil) else (make-instance class :scheme scheme :host host :port port :path path - :parsed-path parsed-path + :parsed-path parsed-path :parsed-host parsed-host :query query :fragment fragment :plist plist :escaped escaped :string nil :hashcode nil))) @@ -342,6 +355,17 @@ (setf (.uri-parsed-path uri) path-list) path-list) +(defmethod uri-parsed-host ((uri uri)) + (when (uri-host uri) + (when (null (.uri-parsed-host uri)) + (setf (.uri-parsed-host uri) + (to-unicode (uri-host uri)))) + (.uri-parsed-host uri))) + +(defmethod (setf uri-parsed-host) (host (uri uri)) + (setf (uri-host uri) (to-ascii host)) + (setf (.uri-parsed-host uri) (to-unicode host))) + (defun uri-authority (uri) (when (uri-host uri) (let ((*print-pretty* nil)) @@ -456,9 +480,9 @@ (when (and scheme (eq :urn scheme)) (return-from parse-uri - (make-instance 'urn :scheme scheme :nid host :nss path))) + (make-instance 'urn :scheme scheme :nid host :nss (to-ascii path)))) - (when host (setq host (decode-escaped-encoding host escape))) + (when host (setq host (to-ascii (decode-escaped-encoding host escape)))) (when port (setq port (read-from-string port)) (when (not (numberp port)) (error "port is not a number: ~s." port)) diff --git a/tests.lisp b/tests.lisp index 0344922..fe9eda7 100644 --- a/tests.lisp +++ b/tests.lisp @@ -250,6 +250,24 @@ (parse-uri "ftp://parcftp.xerox.com:/pub/pcl/mop/")) :test 'string=) res) + (push `(test + "http://xn--mller-kva.example.com/" + (format nil "~a" + (parse-uri "http://xn--mller-kva.example.com/")) + :test 'string=) + res) + (push `(test + "http://xn--mller-kva.example.com/" + (format nil "~a" + (parse-uri "http://müller.example.com/")) + :test 'string=) + res) + (push `(test + "http://example.xn--fiqz9s/" + (format nil "~a" + (parse-uri "http://example.中國/")) + :test 'string=) + res) ;;;; enough-uri tests (dolist (x `(("http://www.franz.com/foo/bar/baz.htm" -- 1.7.10.4