PageRenderTime 72ms CodeModel.GetById 16ms app.highlight 9ms RepoModel.GetById 44ms app.codeStats 1ms

/src/util/uri.lisp

http://github.com/skypher/cl-oauth
Lisp | 125 lines | 111 code | 11 blank | 3 comment | 3 complexity | dad0ab1d3c764a2f817c7787aa6adb2f MD5 | raw file
  1
  2(in-package :oauth)
  3
  4(export '(url-encode))
  5
  6(defvar +utf-8+ (flexi-streams:make-external-format :utf8 :eol-style :lf))
  7
  8;; this function is taken from Hunchentoot but modified to
  9;; satisfy the OAuth spec demands.
 10(defun url-encode (input &optional (external-format +utf-8+))
 11  "URL-encodes INPUT according to the percent encoding rules of
 12  RFC5849 (section 3.6).  If a string is passed as INPUT, it is
 13  encoded using the external format EXTERNAL-FORMAT.  If a vector of
 14  bytes is passed, the values are used verbatim."
 15  (with-output-to-string (s)
 16    (loop for octet across (etypecase input
 17                             (string
 18                              (flexi-streams:string-to-octets input :external-format external-format))
 19                             ((or (array (integer) (*))
 20                                  (array (unsigned-byte 8) (*)))
 21                              input)
 22                             (null
 23                              #()))
 24          for char = (code-char octet)
 25          do (if (or (char<= #\0 char #\9)
 26                     (char<= #\a char #\z)
 27                     (char<= #\A char #\Z)
 28                     (find char "-_.~" :test #'char=))
 29                 (write-char char s)
 30                 (format s "%~2,'0x" octet)))))
 31
 32(defmacro upgrade-vector (vector new-type &key converter)
 33  "Returns a vector with the same length and the same elements as
 34VECTOR \(a variable holding a vector) but having element type
 35NEW-TYPE.  If CONVERTER is not NIL, it should designate a function
 36which will be applied to each element of VECTOR before the result is
 37stored in the new vector.  The resulting vector will have a fill
 38pointer set to its end.
 39
 40The macro also uses SETQ to store the new vector in VECTOR."
 41  `(setq ,vector
 42         (loop with length = (length ,vector)
 43               with new-vector = (make-array length
 44                                             :element-type ,new-type
 45                                             :fill-pointer length)
 46               for i below length
 47               do (setf (aref new-vector i) ,(if converter
 48                                               `(funcall ,converter (aref ,vector i))
 49                                               `(aref ,vector i)))
 50               finally (return new-vector))))
 51
 52;;; this function is taken from Hunchentoot 1.1.0 without effective modification
 53(defun url-decode (string &optional (external-format +utf-8+))
 54  "Decodes a URL-encoded STRING which is assumed to be encoded using
 55the external format EXTERNAL-FORMAT."
 56  (when (zerop (length string))
 57    (return-from url-decode ""))
 58  (let ((vector (make-array (length string) :element-type '(unsigned-byte 8) :fill-pointer 0))
 59        (i 0)
 60        unicodep)
 61    (loop
 62      (unless (< i (length string))
 63        (return))
 64      (let ((char (aref string i)))
 65       (labels ((decode-hex (length)
 66                  (prog1
 67                      (parse-integer string :start i :end (+ i length) :radix 16)
 68                    (incf i length)))
 69                (push-integer (integer)
 70                  (vector-push integer vector))
 71                (peek ()
 72                  (aref string i))
 73                (advance ()
 74                  (setq char (peek))
 75                  (incf i)))
 76         (cond
 77          ((char= #\% char)
 78           (advance)
 79           (cond
 80            ((char= #\u (peek))
 81             (unless unicodep
 82               (setq unicodep t)
 83               (upgrade-vector vector '(integer 0 65535)))
 84             (advance)
 85             (push-integer (decode-hex 4)))
 86            (t
 87             (push-integer (decode-hex 2)))))
 88          (t
 89           (push-integer (char-code (case char
 90                                      ((#\+) #\Space)
 91                                      (otherwise char))))
 92           (advance))))))
 93    (cond (unicodep
 94           (upgrade-vector vector 'character :converter #'code-char))
 95          (t (flexi-streams:octets-to-string vector :external-format external-format)))))
 96
 97
 98(defmethod normalize-uri ((uri string))
 99  (normalize-uri (puri:parse-uri uri)))
100
101(defmethod normalize-uri ((uri puri:uri))
102  "9.1.2"
103  (let ((*print-case* :downcase) ; verify that this works!!
104        (scheme (puri:uri-scheme uri))
105        (host (puri:uri-host uri))
106        (port (puri:uri-port uri))
107        (path (puri:uri-path uri)))
108    (values
109      (concatenate 'string
110        (string-downcase (princ-to-string scheme))
111        "://"
112        (string-downcase host)
113        (cond
114          ((null port)
115           "")
116          ((and (eq scheme :http) (eql port 80))
117           "")
118          ((and (eq scheme :https) (eql port 443))
119           "")
120          (t
121           (concatenate 'string ":" (princ-to-string port))))
122        path)
123      (awhen (puri:uri-query uri)
124        (query-string->alist it)))))
125