PageRenderTime 24ms CodeModel.GetById 0ms RepoModel.GetById 1ms app.codeStats 0ms

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