-
Notifications
You must be signed in to change notification settings - Fork 10
/
util.lisp
202 lines (184 loc) · 8.99 KB
/
util.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Copyright (c) 2011, Peter Seibel. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :toot)
(defun escape-for-html (string)
"Escapes the characters #\\<, #\\>, #\\', #\\\", and #\\& for HTML output."
(with-output-to-string (out)
(with-input-from-string (in string)
(loop for char = (read-char in nil nil)
while char
do (case char
((#\<) (write-string "<" out))
((#\>) (write-string ">" out))
((#\") (write-string """ out))
((#\') (write-string "'" out))
((#\&) (write-string "&" out))
(otherwise (write-char char out)))))))
(defun rfc-1123-date (&optional (time (get-universal-time)))
"Generates a time string according to RFC 1123. Default is current time."
(multiple-value-bind
(second minute hour date month year day-of-week)
(decode-universal-time time 0)
(format nil "~A, ~2,'0d ~A ~4d ~2,'0d:~2,'0d:~2,'0d GMT"
(svref +day-names+ day-of-week)
date
(svref +month-names+ (1- month))
year
hour
minute
second)))
;; FIXME: this is lacking time zone. Should probably log on zulu time.
(defun iso-time (&optional (time (get-universal-time)))
"Returns the universal time TIME as a string in full ISO format."
(multiple-value-bind (second minute hour date month year)
(decode-universal-time time)
(format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d"
year month date hour minute second)))
(defun tmp-filename ()
(loop for pathname = (possible-tmp-filename)
when (not (probe-file pathname)) return pathname))
(defun possible-tmp-filename ()
(let ((n (with-lock-held (*tmp-counter-lock*) (incf *tmp-counter*))))
(make-pathname :name (format nil "toottmp-~d" n) :type nil :defaults *tmp-directory*)))
(defun quote-string (string)
"Quotes string according to RFC 2616's definition of `quoted-string'."
(with-output-to-string (out)
(with-input-from-string (in string)
(loop for char = (read-char in nil nil)
while char
unless (or (char< char #\Space)
(char= char #\Rubout))
do (case char
((#\\) (write-string "\\\\" out))
((#\") (write-string "\\\"" out))
(otherwise (write-char char out)))))))
(defmacro upgrade-vector (vector new-type &key converter)
"Returns a vector with the same length and the same elements as
VECTOR \(a variable holding a vector) but having element type
NEW-TYPE. If CONVERTER is not NIL, it should designate a function
which will be applied to each element of VECTOR before the result is
stored in the new vector. The resulting vector will have a fill
pointer set to its end.
The macro also uses SETF to store the new vector in VECTOR."
`(setf ,vector
(loop with length = (length ,vector)
with new-vector = (make-array length
:element-type ,new-type
:fill-pointer length)
for i below length
do (setf (aref new-vector i) ,(if converter
`(funcall ,converter (aref ,vector i))
`(aref ,vector i)))
finally (return new-vector))))
(defun url-decode (string &optional (external-format *default-external-format*))
"Decodes a URL-encoded STRING which is assumed to be encoded using
the external format EXTERNAL-FORMAT."
(when (zerop (length string))
(return-from url-decode ""))
(let ((vector (make-array (length string) :element-type 'octet :fill-pointer 0))
(i 0)
unicodep)
(loop
(unless (< i (length string))
(return))
(let ((char (aref string i)))
(labels ((decode-hex (length)
(prog1
(parse-integer string :start i :end (+ i length) :radix 16)
(incf i length)))
(push-integer (integer)
(vector-push integer vector))
(peek ()
(aref string i))
(advance ()
(setf char (peek))
(incf i)))
(cond
((char= #\% char)
(advance)
(cond
((char= #\u (peek))
(unless unicodep
(setf unicodep t)
(upgrade-vector vector '(integer 0 65535)))
(advance)
(push-integer (decode-hex 4)))
(t
(push-integer (decode-hex 2)))))
(t
(push-integer (char-code (case char
((#\+) #\Space)
(otherwise char))))
(advance))))))
(cond (unicodep
(upgrade-vector vector 'character :converter #'code-char))
(t (octets-to-string vector :external-format external-format)))))
(defun form-url-encoded-list-to-alist (form-url-encoded-list
&optional (external-format *default-external-format*))
"Converts a list FORM-URL-ENCODED-LIST of name/value pairs into an
alist. Both names and values are url-decoded while doing this."
(mapcar #'(lambda (entry)
(destructuring-bind (name &optional value)
(split "=" entry :limit 2)
(cons (string-trim " " (url-decode name external-format))
(url-decode (or value "") external-format))))
form-url-encoded-list))
(defun url-encode (string &optional (external-format *default-external-format*))
"URL-encodes a string using the external format EXTERNAL-FORMAT."
(with-output-to-string (s)
(loop for c across string
for index from 0
do (cond ((or (char<= #\0 c #\9)
(char<= #\a c #\z)
(char<= #\A c #\Z)
;; note that there's no comma in there - because of cookies
(find c "$-_.!*'()" :test #'char=))
(write-char c s))
(t (loop for octet across (string-to-octets string
:start index
:end (1+ index)
:external-format external-format)
do (format s "%~2,'0x" octet)))))))
(defun parse-content-type-header (content-type-header)
"Reads and parses a `Content-Type' header and returns it as three
values - the type, the subtype, and the requests' character set as
specified in the 'charset' parameter in the header, if there is one
and if the content type is \"text\". CONTENT-TYPE-HEADER is supposed
to be the corresponding header value as a string."
(with-input-from-sequence (stream (map 'list 'char-code content-type-header))
(with-character-stream-semantics
(let* ((*current-error-message* "Corrupted Content-Type header:")
(type (read-token stream))
(subtype (if (eql #\/ (read-char* stream nil))
(read-token stream)
(return-from parse-content-type-header
;; try to return something meaningful
(values "application" "octet-stream" nil))))
(parameters (read-name-value-pairs stream))
(charset (cdr (assoc "charset" parameters :test #'string=)))
(charset
(when (string-equal type "text")
charset)))
(values type subtype charset)))))
(defun sans (args &rest to-remove)
(loop for (k v) on args by #'cddr unless (member k to-remove) collect k and collect v))