util.lisp 1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
2
3 ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
4
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
7 ;;; are met:
8
9 ;;; * Redistributions of source code must retain the above copyright
10 ;;; notice, this list of conditions and the following disclaimer.
11
12 ;;; * Redistributions in binary form must reproduce the above
13 ;;; copyright notice, this list of conditions and the following
14 ;;; disclaimer in the documentation and/or other materials
15 ;;; provided with the distribution.
16
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28
29 (in-package :hunchentoot)
30
31
32 (defun starts-with-p (seq subseq &key (test 'eql))
33 "Tests whether the sequence SEQ starts with the sequence
34 SUBSEQ. Individual elements are compared with TEST."
35 (let* ((length (length subseq))
36 (mismatch (mismatch subseq seq
37 :test test)))
38 (or (null mismatch)
39 (<= length mismatch))))
40
41 (defun starts-with-one-of-p (seq subseq-list &key (test 'eql))
42 "Tests whether the sequence SEQ starts with one of the
43 sequences in SUBSEQ-LIST. Individual elements are compared with
44 TEST."
45 (some (lambda (subseq)
46 (starts-with-p seq subseq :test test))
47 subseq-list))
48
49 (defun create-random-string (&optional (n 10) (base 16))
50 "Returns a random number \(as a string) with base BASE and N
51 digits."
52 (with-output-to-string (s)
53 (dotimes (i n)
54 (format s "~VR" base
55 (random base *the-random-state*)))))
56
57 (defun reason-phrase (return-code)
58 "Returns a reason phrase for the HTTP return code RETURN-CODE \(which
59 should be an integer) or NIL for return codes Hunchentoot doesn't know."
60 (gethash return-code *http-reason-phrase-map*
61 "No reason phrase known"))
62
63 (defgeneric assoc* (thing alist)
64 (:documentation "Similar to CL:ASSOC, but 'does the right thing' if
65 THING is a string or a symbol.")
66 (:method ((thing symbol) alist)
67 (assoc thing alist :test #'eq))
68 (:method ((thing string) alist)
69 (assoc thing alist :test #'string-equal))
70 (:method (thing alist)
71 (assoc thing alist :test #'eql)))
72
73 (defun md5-hex (string)
74 "Calculates the md5 sum of the string STRING and returns it as a hex string."
75 (with-output-to-string (s)
76 (loop for code across (md5:md5sum-string string)
77 do (format s "~2,'0x" code))))
78
79 (defun escape-for-html (string)
80 "Escapes the characters #\\<, #\\>, #\\', #\\\", and #\\& for HTML
81 output."
82 (with-output-to-string (out)
83 (with-input-from-string (in string)
84 (loop for char = (read-char in nil nil)
85 while char
86 do (case char
87 ((#\<) (write-string "<" out))
88 ((#\>) (write-string ">" out))
89 ((#\") (write-string """ out))
90 ((#\') (write-string "'" out))
91 ((#\&) (write-string "&" out))
92 (otherwise (write-char char out)))))))
93
94 (defun http-token-p (token)
95 "This function tests whether OBJECT is a non-empty string which is a
96 TOKEN according to RFC 2068 \(i.e. whether it may be used for, say,
97 cookie names)."
98 (and (stringp token)
99 (plusp (length token))
100 (every (lambda (char)
101 (and ;; CHAR is US-ASCII but not control character or ESC
102 (< 31 (char-code char) 127)
103 ;; CHAR is not 'tspecial'
104 (not (find char "()<>@,;:\\\"/[]?={} " :test #'char=))))
105 token)))
106
107
108 (defun rfc-1123-date (&optional (time (get-universal-time)))
109 "Generates a time string according to RFC 1123. Default is current time.
110 This can be used to send a 'Last-Modified' header - see
111 HANDLE-IF-MODIFIED-SINCE."
112 (multiple-value-bind
113 (second minute hour date month year day-of-week)
114 (decode-universal-time time 0)
115 (format nil "~A, ~2,'0d ~A ~4d ~2,'0d:~2,'0d:~2,'0d GMT"
116 (svref +day-names+ day-of-week)
117 date
118 (svref +month-names+ (1- month))
119 year
120 hour
121 minute
122 second)))
123
124 (defun iso-time (&optional (time (get-universal-time)))
125 "Returns the universal time TIME as a string in full ISO format."
126 (multiple-value-bind (second minute hour date month year)
127 (decode-universal-time time)
128 (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d"
129 year month date hour minute second)))
130
131 (let ((counter 0))
132 (declare (ignorable counter))
133 (defun make-tmp-file-name (&optional (prefix "hunchentoot"))
134 "Generates a unique name for a temporary file. This function is
135 called from the RFC2388 library when a file is uploaded."
136 (let ((tmp-file-name
137 #+:allegro
138 (pathname (system:make-temp-file-name prefix *tmp-directory*))
139 #-:allegro
140 (loop for pathname = (make-pathname :name (format nil "~A-~A"
141 prefix (incf counter))
142 :type nil
143 :defaults *tmp-directory*)
144 unless (probe-file pathname)
145 return pathname)))
146 (push tmp-file-name *tmp-files*)
147 ;; maybe call hook for file uploads
148 (when *file-upload-hook*
149 (funcall *file-upload-hook* tmp-file-name))
150 tmp-file-name)))
151
152 (defun quote-string (string)
153 "Quotes string according to RFC 2616's definition of `quoted-string'."
154 (with-output-to-string (out)
155 (with-input-from-string (in string)
156 (loop for char = (read-char in nil nil)
157 while char
158 unless (or (char< char #\Space)
159 (char= char #\Rubout))
160 do (case char
161 ((#\\) (write-string "\\\\" out))
162 ((#\") (write-string "\\\"" out))
163 (otherwise (write-char char out)))))))
164
165 (defmacro upgrade-vector (vector new-type &key converter)
166 "Returns a vector with the same length and the same elements as
167 VECTOR \(a variable holding a vector) but having element type
168 NEW-TYPE. If CONVERTER is not NIL, it should designate a function
169 which will be applied to each element of VECTOR before the result is
170 stored in the new vector. The resulting vector will have a fill
171 pointer set to its end.
172
173 The macro also uses SETQ to store the new vector in VECTOR."
174 `(setq ,vector
175 (loop with length = (length ,vector)
176 with new-vector = (make-array length
177 :element-type ,new-type
178 :fill-pointer length)
179 for i below length
180 do (setf (aref new-vector i) ,(if converter
181 `(funcall ,converter (aref ,vector i))
182 `(aref ,vector i)))
183 finally (return new-vector))))
184
185 (defun ensure-parse-integer (string &key (start 0) end (radix 10))
186 (let ((end (or end (length string))))
187 (if (or (>= start (length string))
188 (> end (length string)))
189 (error 'bad-request)
190 (multiple-value-bind (integer stopped)
191 (parse-integer string :start start :end end :radix radix :junk-allowed t)
192 (if (/= stopped end)
193 (error 'bad-request)
194 integer)))))
195
196 (defun url-decode (string &optional (external-format *hunchentoot-default-external-format*))
197 "Decodes a URL-encoded string which is assumed to be encoded using the
198 external format EXTERNAL-FORMAT, i.e. this is the inverse of
199 URL-ENCODE. It is assumed that you'll rarely need this function, if
200 ever. But just in case - here it is. The default for EXTERNAL-FORMAT is
201 the value of *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*."
202 (when (zerop (length string))
203 (return-from url-decode ""))
204 (let ((vector (make-array (length string) :element-type 'octet :fill-pointer 0))
205 (i 0)
206 unicodep)
207 (loop
208 (unless (< i (length string))
209 (return))
210 (let ((char (aref string i)))
211 (labels ((decode-hex (length)
212 (ensure-parse-integer string :start i :end (incf i length)
213 :radix 16))
214 (push-integer (integer)
215 (vector-push integer vector))
216 (peek ()
217 (if (array-in-bounds-p string i)
218 (aref string i)
219 (error 'bad-request)))
220 (advance ()
221 (setq char (peek))
222 (incf i)))
223 (cond
224 ((char= #\% char)
225 (advance)
226 (cond
227 ((char= #\u (peek))
228 (unless unicodep
229 (setq unicodep t)
230 (upgrade-vector vector '(integer 0 65535)))
231 (advance)
232 (push-integer (decode-hex 4)))
233 (t
234 (push-integer (decode-hex 2)))))
235 (t
236 (push-integer (char-code (case char
237 ((#\+) #\Space)
238 (otherwise char))))
239 (advance))))))
240 (cond (unicodep
241 (upgrade-vector vector 'character :converter #'code-char))
242 (t (octets-to-string vector :external-format external-format)))))
243
244 (defun form-url-encoded-list-to-alist (form-url-encoded-list
245 &optional (external-format *hunchentoot-default-external-format*))
246 "Converts a list FORM-URL-ENCODED-LIST of name/value pairs into an
247 alist. Both names and values are url-decoded while doing this."
248 (mapcar #'(lambda (entry)
249 (destructuring-bind (name &optional value)
250 (split "=" entry :limit 2)
251 (cons (string-trim " " (url-decode name external-format))
252 (url-decode (or value "") external-format))))
253 form-url-encoded-list))
254
255 (defun cookies-to-alist (cookies)
256 "Converts a list of cookies of the form \"key=value\" to an alist. No
257 character set processing is done."
258 (mapcar #'(lambda (entry)
259 (destructuring-bind (name &optional value)
260 (split "=" entry :limit 2)
261 (cons (string-trim " " name) (or value ""))))
262 cookies))
263
264 (defun url-encode (string &optional (external-format *hunchentoot-default-external-format*))
265 "URL-encodes a string using the external format EXTERNAL-FORMAT. The
266 default for EXTERNAL-FORMAT is the value of
267 *HUNCHENTOOT-DEFAULT-EXTERNAL-FORMAT*."
268 (with-output-to-string (s)
269 (loop for c across string
270 for index from 0
271 do (cond ((or (char<= #\0 c #\9)
272 (char<= #\a c #\z)
273 (char<= #\A c #\Z)
274 ;; note that there's no comma in there - because of cookies
275 (find c "$-_.!*'()" :test #'char=))
276 (write-char c s))
277 (t (loop for octet across (string-to-octets string
278 :start index
279 :end (1+ index)
280 :external-format external-format)
281 do (format s "%~2,'0x" octet)))))))
282
283 (defun parse-content-type (content-type-header)
284 "Reads and parses a `Content-Type' header and returns it as three
285 values - the type, the subtype, and the requests' character set as
286 specified in the 'charset' parameter in the header, if there is one
287 and if the content type is \"text\". CONTENT-TYPE-HEADER is supposed
288 to be the corresponding header value as a string."
289 (with-input-from-sequence (stream (map 'list 'char-code content-type-header))
290 (with-character-stream-semantics
291 (let* ((*current-error-message* (format nil "Corrupted Content-Type header ~S:" content-type-header))
292 (type (read-token stream))
293 (subtype (if (eql #\/ (read-char* stream nil))
294 (read-token stream)
295 (return-from parse-content-type
296 ;; try to return something meaningful
297 (values "application" "octet-stream" nil))))
298 (parameters (read-name-value-pairs stream))
299 (charset (cdr (assoc "charset" parameters :test #'string=)))
300 (charset
301 (when (string-equal type "text")
302 charset)))
303 (values type subtype charset)))))
304
305 (defun keep-alive-p (request)
306 "Returns a true value unless the incoming request's headers or the
307 server's PERSISTENT-CONNECTIONS-P setting obviate a keep-alive reply.
308 The second return value denotes whether the client has explicitly
309 asked for a persistent connection."
310 (let ((connection-values
311 ;; the header might consist of different values separated by commas
312 (when-let (connection-header (header-in :connection request))
313 (split "\\s*,\\s*" connection-header))))
314 (flet ((connection-value-p (value)
315 "Checks whether the string VALUE is one of the
316 values of the `Connection' header."
317 (member value connection-values :test #'string-equal)))
318 (let ((keep-alive-requested-p (connection-value-p "keep-alive")))
319 (values (and (acceptor-persistent-connections-p *acceptor*)
320 (or (and (eq (server-protocol request) :http/1.1)
321 (not (connection-value-p "close")))
322 (and (eq (server-protocol request) :http/1.0)
323 keep-alive-requested-p)))
324 keep-alive-requested-p)))))
325
326 (defun address-string ()
327 "Returns a string with information about Hunchentoot suitable for
328 inclusion in HTML output."
329 (flet ((escape-for-html (arg)
330 (if arg
331 (escape-for-html arg)
332 arg)))
333 (format nil "<address><a href='http://weitz.de/hunchentoot/'>Hunchentoot ~A</a> <a href='~A'>(~A ~A)</a>~@[ at ~A~:[ (port ~D)~;~]~]</address>"
334 *hunchentoot-version*
335 +implementation-link+
336 (escape-for-html (lisp-implementation-type))
337 (escape-for-html (lisp-implementation-version))
338 (escape-for-html (or (host *request*) (acceptor-address *acceptor*)))
339 (scan ":\\d+$" (or (host *request*) ""))
340 (acceptor-port *acceptor*))))
341
342 (defun input-chunking-p ()
343 "Whether input chunking is currently switched on for
344 *HUNCHENTOOT-STREAM* - note that this will return NIL if the stream
345 not a chunked stream."
346 (chunked-stream-input-chunking-p *hunchentoot-stream*))
347
348 (defun ssl-p (&optional (acceptor *acceptor*))
349 "Whether the current connection to the client is secure. See
350 ACCEPTOR-SSL-P."
351 (acceptor-ssl-p acceptor))
352
353 (defmacro with-mapped-conditions (() &body body)
354 "Run BODY with usocket condition mapping in effect, i.e. platform specific network errors will be
355 signalled as usocket conditions. For Lispworks, no mapping is performed."
356 #+:lispworks
357 `(progn ,@body)
358 #-:lispworks
359 `(usocket:with-mapped-conditions ()
360 ,@body))
361
362 (defmacro with-conditions-caught-and-logged (() &body body)
363 "Run BODY with conditions caught and logged by the *ACCEPTOR*. Errors are
364 stopped right away so no other part of the software is impacted by them."
365 `(block nil
366 (handler-bind
367 ((error
368 ;; abort if there's an error which isn't caught inside
369 (lambda (cond)
370 (log-message* *lisp-errors-log-level*
371 "Error while processing connection: ~A" cond)
372 (return)))
373 (warning
374 ;; log all warnings which aren't caught inside
375 (lambda (cond)
376 (when *log-lisp-warnings-p*
377 (log-message* *lisp-warnings-log-level*
378 "Warning while processing connection: ~A" cond)))))
379 ,@body)))