Commit 3a4235e8 authored by Vladimir Sedach's avatar Vladimir Sedach

Made uri encoding/decoding functions work with unicode

parent e96566e5
......@@ -6,14 +6,28 @@ True by default.")
(defun uri-decode (str)
"Decodes URI encoded/escaped characters in the given string."
(regex-replace-all "%[\\d|a-f|A-F]{2}" str (lambda (match) (string (code-char (parse-integer match :start 1 :radix 16)))) :simple-calls t))
(let ((octets (make-array (length str)
:element-type 'flexi-streams:octet
:adjustable t :fill-pointer 0)))
(do ((i 0 (incf i)))
((>= i (length str)))
(let ((c (aref str i)))
(vector-push
(if (eql c #\%)
(prog1 (parse-integer str :start (1+ i) :end (+ i 3)
:radix 16)
(incf i 2))
(char-code c))
octets)))
(flexi-streams:octets-to-string octets :external-format :utf8)))
(defmacro weak-register-groups-bind (vars regex str &body body)
`(destructuring-bind (&optional ,@vars)
(coerce (nth-value 1 (scan-to-strings ,regex ,str)) 'list)
(declare (ignorable ,@vars))
,(when uri-decode?
`(setf ,@(loop for var in vars append `(,var (when ,var (uri-decode ,var))))))
`(setf ,@(loop for var in vars append
`(,var (when ,var (uri-decode ,var))))))
,@body))
(defmacro uri-template-bind ((template) uri &body body)
......@@ -38,17 +52,28 @@ The standard URI components look like:
%uri-head http://user@www.foo.com:8080
%uri-tail /dir/abc?bar=baz&xyz=1#hash"
(let* ((template (cdr template)) ;; template is expected to look like output of #U: '(uri-template &rest args)
(template-vars (mapcar (lambda (x) (car (last (second x)))) (remove-if #'stringp template)))
(template-vars (mapcar (lambda (x)
(car (last (second x))))
(remove-if #'stringp template)))
(uri-var (gensym)))
`(let ((,uri-var ,uri))
(weak-register-groups-bind (%uri-head x1 %uri-scheme x2 %uri-authority %uri-tail %uri-path x3 %uri-query x4 %uri-fragment)
;; regex adapted from RFC 2396: "^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\\?([^#]*))?(#(.*))?"
"^((([^:/?#]+):)?(//([^/?#]*)))?(([^?#]*)(\\?([^#]*))?(#(.*))?)" ,uri-var
"^((([^:/?#]+):)?(//([^/?#]*)))?(([^?#]*)(\\?([^#]*))?(#(.*))?)"
,uri-var
(weak-register-groups-bind (x1 %uri-user %uri-host x2 %uri-port)
"(([^@]+)@)?([^\\:]+)(\\:(\\d+))?" %uri-authority
"(([^@]+)@)?([^\\:]+)(\\:(\\d+))?"
%uri-authority
(weak-register-groups-bind (%uri-directory %uri-file)
"(.*/)([^/]+)?" %uri-path
"(.*/)([^/]+)?"
%uri-path
(weak-register-groups-bind ,template-vars
'(:sequence :start-anchor ,@(substitute-if '(:register (:greedy-repetition 0 nil :everything)) (complement #'stringp) template) :end-anchor) ,uri-var
'(:sequence
:start-anchor
,@(substitute-if
'(:register (:greedy-repetition 0 nil :everything))
(complement #'stringp)
template)
:end-anchor) ,uri-var
(when (and ,@template-vars)
,@body))))))))
......@@ -37,4 +37,6 @@
(defreadtable uri-template
(:merge :standard)
(:dispatch-macro-char #\# #\U (lambda (&rest args) (apply #'uri-template-reader args))))
(:dispatch-macro-char #\# #\U
(lambda (&rest args)
(apply #'uri-template-reader args))))
......@@ -8,7 +8,8 @@
(defun run-tests ()
(run-interpolation-tests)
(run-destructuring-tests))
(run-destructuring-tests)
(run-encoding-tests))
(defun run-interpolation-tests ()
(let ((baz 1)
......@@ -20,7 +21,7 @@
(assert (string= #Uhttp://www.foo.com/bar/{bar}{baz}
"http://www.foo.com/bar/bar1"))
(assert (string= #Uhttp://www.foo.com/bar?foo={"^BAZ !bar"}
"http://www.foo.com/bar?foo=^BAZ%20%21bar"))))
"http://www.foo.com/bar?foo=%5EBAZ%20!bar"))))
(defun run-destructuring-tests ()
(assert (equal (uri-template-bind (#Uhttp://www.factory.com/orders/{part}/{number})
......@@ -61,3 +62,11 @@
%uri-authority (list %uri-user %uri-host %uri-port)
%uri-path (list %uri-directory %uri-file) %uri-query %uri-fragment))
'(NIL "/foo/bar" NIL NIL (NIL NIL NIL) "/foo/bar" ("/foo/" "bar") NIL NIL))))
(defun run-encoding-tests ()
(assert (string= "abc123" (uri-encode "abc123")))
(assert (string= "abc%20123" (uri-encode "abc 123")))
(assert (string= "%D1%84%D0%BE%D0%BE" (uri-encode "фоо")))
(assert (string= "abc123" (uri-decode "abc123")))
(assert (string= "abc 123" (uri-decode "abc%20123")))
(assert (string= "бар" (uri-decode "%D0%B1%D0%B0%D1%80"))))
......@@ -4,6 +4,7 @@
:description "An implementation of the URI Template proposed standard draft version 01."
:long-description "An implementation of the URI Template proposed standard draft version 01.
Lets you easily create and parse URIs by using the URI Template reader macro syntax."
:author "Vladimir Sedach <vsedach@gmail.com>"
:license "LLGPLv3"
:serial t
:components ((:file "package")
......@@ -11,4 +12,4 @@ Lets you easily create and parse URIs by using the URI Template reader macro syn
(:file "destructure-uri")
#+parenscript (:file "parenscript-implementation")
)
:depends-on (:cl-ppcre :named-readtables))
:depends-on (:cl-ppcre :named-readtables :flexi-streams))
......@@ -4,29 +4,40 @@
"Controls whether URI encoding/escaping is done on the templated value.
True by default.")
;;; stolen from hunchentoot
(defun uri-encode (str)
"URI encodes/escapes the given string."
(regex-replace-all '(:alternation #\Space #\! #\* #\' #\( #\) #\; #\: #\@ #\& #\= #\+ #\$ #\, #\/ #\? #\# #\[ #\])
str
(lambda (match) (format nil "%~16R" (char-code (elt match 0))))
:simple-calls t))
(with-output-to-string (s)
(loop for c across (flexi-streams:string-to-octets str :external-format :utf-8)
do (if (or (<= 48 c 57)
(<= 65 c 90)
(<= 97 c 122)
(find c '(36 45 95 46 33 42 39 40 41)))
(write-char (code-char c) s)
(format s "%~2,'0x" c)))))
(defun read-uri-template (stream &optional recursive-p)
"A function suitable for inserting into the readtable so you can
read URI templates from your own dispatch character."
(let ((*readtable* (copy-readtable))
(template-accumulator ())
(string-accumulator #1=(make-array 10 :element-type 'character :adjustable t :fill-pointer 0))
(string-accumulator #1=(make-array 10
:element-type 'character
:adjustable t :fill-pointer 0))
(next-char))
(set-syntax-from-char #\} #\))
(flet ((collect-string ()
(when (< 0 (length string-accumulator))
(push string-accumulator template-accumulator)
(setf string-accumulator #1#))))
(loop until (member (setf next-char (read-char stream nil #\Space recursive-p)) '(#\Space #\Newline #\Tab #\)))
(loop until (member
(setf next-char (read-char stream nil #\Space recursive-p))
'(#\Space #\Newline #\Tab #\)))
do (if (char= #\{ next-char)
(progn (collect-string)
(push `(maybe-uri-encode (progn ,@(read-delimited-list #\} stream))) template-accumulator))
(push `(maybe-uri-encode
(progn ,@(read-delimited-list #\} stream))
) template-accumulator))
(vector-push-extend next-char string-accumulator))
finally (unread-char next-char stream) (collect-string))
(reverse template-accumulator))))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment