Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Made uri encoding/decoding functions work with unicode

  • Loading branch information...
commit 3a4235e873bca32b83b5eaa002d00680b0464f57 1 parent e96566e
@vsedach authored
View
39 destructure-uri.lisp
@@ -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))))))))
View
4 package.lisp
@@ -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))))
View
13 uri-template-test.lisp
@@ -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"))))
View
3  uri-template.asd
@@ -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))
View
25 uri-template.lisp
@@ -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))))
Please sign in to comment.
Something went wrong with that request. Please try again.