1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
2 ;;; $Header: /usr/local/cvsrep/hunchentoot/util.lisp,v 1.35 2008/04/08 14:39:18 edi Exp $
4 ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 (in-package :hunchentoot
)
33 (defun starts-with-p (seq subseq
&key
(test 'eql
))
34 "Tests whether the sequence SEQ starts with the sequence
35 SUBSEQ. Individual elements are compared with TEST."
36 (let* ((length (length subseq
))
37 (mismatch (mismatch subseq seq
40 (<= length mismatch
))))
42 (defun starts-with-one-of-p (seq subseq-list
&key
(test 'eql
))
43 "Tests whether the sequence SEQ starts with one of the
44 sequences in SUBSEQ-LIST. Individual elements are compared with
46 (some (lambda (subseq)
47 (starts-with-p seq subseq
:test test
))
50 (defun create-random-string (&optional
(n 10) (base 16))
51 "Returns a random number \(as a string) with base BASE and N
53 (with-output-to-string (s)
56 (random base
*the-random-state
*)))))
58 (defun reason-phrase (return-code)
59 "Returns a reason phrase for the HTTP return code RETURN-CODE
60 \(which should be an integer) or NIL for return codes Hunchentoot
62 (gethash return-code
*http-reason-phrase-map
*
63 "No reason phrase known"))
65 (defgeneric assoc
* (thing alist
)
66 (:documentation
"Similar to CL:ASSOC, but 'does the right thing' if
67 THING is a string or a symbol.")
68 (:method
((thing symbol
) alist
)
69 (assoc thing alist
:test
#'eq
))
70 (:method
((thing string
) alist
)
71 (assoc thing alist
:test
#'string-equal
))
72 (:method
(thing alist
)
73 (assoc thing alist
:test
#'eql
)))
75 (defun md5-hex (string)
76 "Calculates the md5 sum of the string STRING and returns it as a hex string."
77 (with-output-to-string (s)
78 (loop for code across
(md5:md5sum-sequence
(coerce string
'simple-string
))
79 do
(format s
"~2,'0x" code
))))
81 (defun escape-for-html (string)
82 "Escapes the characters #\\<, #\\>, #\\', #\\\", and #\\& for HTML output."
83 (with-output-to-string (out)
84 (with-input-from-string (in string
)
85 (loop for char
= (read-char in nil nil
)
88 ((#\
<) (write-string "<" out
))
89 ((#\
>) (write-string ">" out
))
90 ((#\") (write-string """ out
))
91 ((#\') (write-string "'" out
))
92 ((#\
&) (write-string "&" out
))
93 (otherwise (write-char char out
)))))))
95 (defun http-token-p (token)
96 "Tests whether TOKEN is a string which is a valid 'token'
97 according to HTTP/1.1 \(RFC 2068)."
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
=))))
108 (defun rfc-1123-date (&optional
(time (get-universal-time)))
109 "Generates a time string according to RFC 1123. Default is current time."
111 (second minute hour date month year day-of-week
)
112 (decode-universal-time time
0)
113 (format nil
"~A, ~2,'0d ~A ~4d ~2,'0d:~2,'0d:~2,'0d GMT"
114 (svref +day-names
+ day-of-week
)
116 (svref +month-names
+ (1- month
))
122 (defun iso-time (&optional
(time (get-universal-time)))
123 "Returns the universal time TIME as a string in full ISO format."
124 (multiple-value-bind (second minute hour date month year
)
125 (decode-universal-time time
)
126 (format nil
"~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d"
127 year month date hour minute second
)))
130 (declare (ignorable counter
))
131 (defun make-tmp-file-name (&optional
(prefix "hunchentoot"))
132 "Generates a unique name for a temporary file. This function is
133 called from the RFC2388 library when a file is uploaded."
136 (pathname (system:make-temp-file-name prefix
*tmp-directory
*))
138 (loop for pathname
= (make-pathname :name
(format nil
"~A-~A"
139 prefix
(incf counter
))
141 :defaults
*tmp-directory
*)
142 unless
(probe-file pathname
)
144 (push tmp-file-name
*tmp-files
*)
145 ;; maybe call hook for file uploads
146 (when *file-upload-hook
*
147 (funcall *file-upload-hook
* tmp-file-name
))
150 (defun quote-string (string)
151 "Quotes string according to RFC 2616's definition of `quoted-string'."
152 (with-output-to-string (out)
153 (with-input-from-string (in string
)
154 (loop for char
= (read-char in nil nil
)
156 unless
(or (char< char
#\Space
)
157 (char= char
#\Rubout
))
159 ((#\\) (write-string "\\\\" out
))
160 ((#\") (write-string "\\\"" out
))
161 (otherwise (write-char char out
)))))))
163 (defmacro upgrade-vector
(vector new-type
&key converter
)
164 "Returns a vector with the same length and the same elements as
165 VECTOR \(a variable holding a vector) but having element type
166 NEW-TYPE. If CONVERTER is not NIL, it should designate a function
167 which will be applied to each element of VECTOR before the result is
168 stored in the new vector. The resulting vector will have a fill
169 pointer set to its end.
171 The macro also uses SETQ to store the new vector in VECTOR."
173 (loop with length
= (length ,vector
)
174 with new-vector
= (make-array length
175 :element-type
,new-type
176 :fill-pointer length
)
178 do
(setf (aref new-vector i
) ,(if converter
179 `(funcall ,converter
(aref ,vector i
))
181 finally
(return new-vector
))))
183 (defun url-decode (string &optional
(external-format *hunchentoot-default-external-format
*))
184 "Decodes a URL-encoded STRING which is assumed to be encoded using
185 the external format EXTERNAL-FORMAT."
186 (when (zerop (length string
))
187 (return-from url-decode
""))
188 (let ((vector (make-array (length string
) :element-type
'octet
:fill-pointer
0))
192 (unless (< i
(length string
))
194 (let ((char (aref string i
)))
195 (labels ((decode-hex (length)
197 (parse-integer string
:start i
:end
(+ i length
) :radix
16)
199 (push-integer (integer)
200 (vector-push integer vector
))
213 (upgrade-vector vector
'(integer 0 65535)))
215 (push-integer (decode-hex 4)))
217 (push-integer (decode-hex 2)))))
219 (push-integer (char-code (case char
224 (upgrade-vector vector
'character
:converter
#'code-char
))
225 (t (octets-to-string vector
:external-format external-format
)))))
227 (defun form-url-encoded-list-to-alist (form-url-encoded-list
228 &optional
(external-format *hunchentoot-default-external-format
*))
229 "Converts a list FORM-URL-ENCODED-LIST of name/value pairs into an
230 alist. Both names and values are url-decoded while doing this."
231 (mapcar #'(lambda (entry)
232 (destructuring-bind (name &optional value
)
233 (split "=" entry
:limit
2)
234 (cons (string-trim " " (url-decode name external-format
))
235 (url-decode (or value
"") external-format
))))
236 form-url-encoded-list
))
238 (defun url-encode (string &optional
(external-format *hunchentoot-default-external-format
*))
239 "URL-encodes a string using the external format EXTERNAL-FORMAT."
240 (with-output-to-string (s)
241 (loop for c across string
243 do
(cond ((or (char<= #\
0 c
#\
9)
246 ;; note that there's no comma in there - because of cookies
247 (find c
"$-_.!*'()" :test
#'char
=))
249 (t (loop for octet across
(string-to-octets string
252 :external-format external-format
)
253 do
(format s
"%~2,'0x" octet
)))))))
255 (defun parse-content-type (content-type-header)
256 "Reads and parses a `Content-Type' header and returns it as three
257 values - the type, the subtype, and the requests' character set as
258 specified in the 'charset' parameter in the header, if there is one
259 and if the content type is \"text\". CONTENT-TYPE-HEADER is supposed
260 to be the corresponding header value as a string."
261 (with-input-from-sequence (stream (map 'list
'char-code content-type-header
))
262 (with-character-stream-semantics
263 (let* ((*current-error-message
* "Corrupted Content-Type header:")
264 (type (read-token stream
))
265 (subtype (if (eql #\
/ (read-char* stream nil
))
267 (return-from parse-content-type
268 ;; try to return something meaningful
269 (values "application" "octet-stream" nil
))))
270 (parameters (read-name-value-pairs stream
))
271 (charset (cdr (assoc "charset" parameters
:test
#'string
=)))
273 (when (string-equal type
"text")
275 (values type subtype charset
)))))
277 (defun keep-alive-p (request)
278 "Returns a true value unless the incoming request's headers or the
279 server's PERSISTENT-CONNECTIONS-P setting obviate a keep-alive reply.
280 The second return value denotes whether the client has explicitly
281 asked for a persistent connection."
282 (let ((connection-values
283 ;; the header might consist of different values separated by commas
284 (when-let (connection-header (header-in :connection request
))
285 (split "\\s*,\\s*" connection-header
))))
286 (flet ((connection-value-p (value)
287 "Checks whether the string VALUE is one of the
288 values of the `Connection' header."
289 (member value connection-values
:test
#'string-equal
)))
290 (let ((keep-alive-requested-p (connection-value-p "keep-alive")))
291 (values (and (acceptor-persistent-connections-p *acceptor
*)
292 (or (and (eq (server-protocol request
) :http
/1.1)
293 (not (connection-value-p "close")))
294 (and (eq (server-protocol request
) :http
/1.0)
295 keep-alive-requested-p
)))
296 keep-alive-requested-p
)))))
298 (defun address-string ()
299 "Returns a string with information about Hunchentoot suitable for
300 inclusion in HTML output."
301 (flet ((escape-for-html (arg)
303 (escape-for-html arg
)
305 (format nil
"<address><a href='http://weitz.de/hunchentoot/'>Hunchentoot ~A</a> <a href='~A'>(~A ~A)</a>~@[ at ~A~:[ (port ~D)~;~]~]</address>"
306 *hunchentoot-version
*
307 +implementation-link
+
308 (escape-for-html (lisp-implementation-type))
309 (escape-for-html (lisp-implementation-version))
310 (escape-for-html (or (host *request
*) (acceptor-address *acceptor
*)))
311 (scan ":\\d+$" (or (host *request
*) ""))
312 (acceptor-port *acceptor
*))))
314 (defun input-chunking-p ()
315 "Whether input chunking is currently switched on for
316 *HUNCHENTOOT-STREAM* - note that this will return NIL if the stream
317 not a chunked stream."
318 (chunked-stream-input-chunking-p *hunchentoot-stream
*))
320 (defun ssl-p (&optional
(acceptor *acceptor
*))
321 "Whether the current connection to the client is secure."
322 (acceptor-ssl-p acceptor
))
324 (defmacro with-mapped-conditions
(() &body body
)
325 "Run BODY with usocket condition mapping in effect, i.e. platform specific network errors will be
326 signalled as usocket conditions. For Lispworks, no mapping is performed."
330 `(usocket:with-mapped-conditions
()