misc.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 (let ((scanner-hash (make-hash-table :test #'equal)))
32 (defun scanner-for-get-param (param-name)
33 "Returns a CL-PPCRE scanner which matches a GET parameter in a
34 URL. Scanners are memoized in SCANNER-HASH once they are created."
35 (or (gethash param-name scanner-hash)
36 (setf (gethash param-name scanner-hash)
37 (create-scanner
38 `(:alternation
39 ;; session=value at end of URL
40 (:sequence
41 (:char-class #\? #\&)
42 ,param-name
43 #\=
44 (:greedy-repetition 0 nil (:inverted-char-class #\&))
45 :end-anchor)
46 ;; session=value with other parameters following
47 (:sequence
48 (:register (:char-class #\? #\&))
49 ,param-name
50 #\=
51 (:greedy-repetition 0 nil (:inverted-char-class #\&))
52 #\&))))))
53 (defun add-cookie-value-to-url (url &key
54 (cookie-name (session-cookie-name *acceptor*))
55 (value (when-let (session (session *request*))
56 (session-cookie-value session)))
57 (replace-ampersands-p t))
58 "Removes all GET parameters named COOKIE-NAME from URL and then
59 adds a new GET parameter with the name COOKIE-NAME and the value
60 VALUE. If REPLACE-AMPERSANDS-P is true all literal ampersands in URL
61 are replaced with '&'. The resulting URL is returned."
62 (unless url
63 ;; see URL-REWRITE:*URL-REWRITE-FILL-TAGS*
64 (setq url (request-uri *request*)))
65 (setq url (regex-replace-all (scanner-for-get-param cookie-name) url "\\1"))
66 (when value
67 (setq url (format nil "~A~:[?~;&~]~A=~A"
68 url
69 (find #\? url)
70 cookie-name
71 (url-encode value))))
72 (when replace-ampersands-p
73 (setq url (regex-replace-all "&" url "&")))
74 url))
75
76 (defun maybe-rewrite-urls-for-session (html &key
77 (cookie-name (session-cookie-name *acceptor*))
78 (value (when-let (session (session *request*))
79 (session-cookie-value session))))
80 "Rewrites the HTML page HTML such that the name/value pair
81 COOKIE-NAME/COOKIE-VALUE is inserted if the client hasn't sent a
82 cookie of the same name but only if *REWRITE-FOR-SESSION-URLS* is
83 true. See the docs for URL-REWRITE:REWRITE-URLS."
84 (cond ((or (not *rewrite-for-session-urls*)
85 (null value)
86 (cookie-in cookie-name))
87 html)
88 (t
89 (with-input-from-string (*standard-input* html)
90 (with-output-to-string (*standard-output*)
91 (url-rewrite:rewrite-urls
92 (lambda (url)
93 (add-cookie-value-to-url url
94 :cookie-name cookie-name
95 :value value))))))))
96
97 (defun create-prefix-dispatcher (prefix handler)
98 "Creates a request dispatch function which will dispatch to the
99 function denoted by HANDLER if the file name of the current request
100 starts with the string PREFIX."
101 (lambda (request)
102 (let ((mismatch (mismatch (script-name request) prefix
103 :test #'char=)))
104 (and (or (null mismatch)
105 (>= mismatch (length prefix)))
106 handler))))
107
108 (defun create-regex-dispatcher (regex handler)
109 "Creates a request dispatch function which will dispatch to the
110 function denoted by HANDLER if the file name of the current request
111 matches the CL-PPCRE regular expression REGEX."
112 (let ((scanner (create-scanner regex)))
113 (lambda (request)
114 (and (scan scanner (script-name request))
115 handler))))
116
117 (defun abort-request-handler (&optional result)
118 "This function can be called by a request handler at any time to
119 immediately abort handling the request. This works as if the handler
120 had returned RESULT. See the source code of REDIRECT for an example."
121 (throw 'handler-done result))
122
123 (defun maybe-handle-range-header (file)
124 "Helper function for handle-static-file. Determines whether the
125 requests specifies a Range header. If so, parses the header and
126 position the already opened file to the location specified. Returns
127 the number of bytes to transfer from the file. Invalid specified
128 ranges are reported to the client with a HTTP 416 status code."
129 (let ((bytes-to-send (file-length file)))
130 (cl-ppcre:register-groups-bind
131 (start end)
132 ("^bytes=(\\d+)-(\\d*)$" (header-in* :range) :sharedp t)
133 ;; body won't be executed if regular expression does not match
134 (setf start (parse-integer start))
135 (setf end (if (> (length end) 0)
136 (parse-integer end)
137 (1- (file-length file))))
138 (when (or (< start 0)
139 (>= end (file-length file)))
140 (setf (return-code*) +http-requested-range-not-satisfiable+
141 (header-out :content-range) (format nil "bytes 0-~D/~D" (1- (file-length file)) (file-length file)))
142 (throw 'handler-done
143 (format nil "invalid request range (requested ~D-~D, accepted 0-~D)"
144 start end (1- (file-length file)))))
145 (file-position file start)
146 (setf (return-code*) +http-partial-content+
147 bytes-to-send (1+ (- end start))
148 (header-out :content-range) (format nil "bytes ~D-~D/~D" start end (file-length file))))
149 bytes-to-send))
150
151 (defun handle-static-file (pathname &optional content-type)
152 "A function which acts like a Hunchentoot handler for the file
153 denoted by PATHNAME. Sends a content type header corresponding to
154 CONTENT-TYPE or \(if that is NIL) tries to determine the content type
155 via the file's suffix."
156 (when (or (wild-pathname-p pathname)
157 (not (fad:file-exists-p pathname))
158 (fad:directory-exists-p pathname))
159 ;; file does not exist
160 (setf (return-code*) +http-not-found+)
161 (abort-request-handler))
162 (unless content-type
163 (setf content-type (mime-type pathname)))
164 (let ((time (or (file-write-date pathname)
165 (get-universal-time)))
166 bytes-to-send)
167 (setf (content-type*) (or (and content-type
168 (maybe-add-charset-to-content-type-header content-type (reply-external-format*)))
169 "application/octet-stream")
170 (header-out :last-modified) (rfc-1123-date time)
171 (header-out :accept-ranges) "bytes")
172 (handle-if-modified-since time)
173 (with-open-file (file pathname
174 :direction :input
175 :element-type 'octet)
176 (setf bytes-to-send (maybe-handle-range-header file)
177 (content-length*) bytes-to-send)
178 (let ((out (send-headers))
179 (buf (make-array +buffer-length+ :element-type 'octet)))
180 (loop
181 (when (zerop bytes-to-send)
182 (return))
183 (let* ((chunk-size (min +buffer-length+ bytes-to-send)))
184 (unless (eql chunk-size (read-sequence buf file :end chunk-size))
185 (error "can't read from input file"))
186 (write-sequence buf out :end chunk-size)
187 (decf bytes-to-send chunk-size)))
188 (finish-output out)))))
189
190 (defun create-static-file-dispatcher-and-handler (uri path &optional content-type)
191 "Creates and returns a request dispatch function which will dispatch
192 to a handler function which emits the file denoted by the pathname
193 designator PATH with content type CONTENT-TYPE if the SCRIPT-NAME of
194 the request matches the string URI. If CONTENT-TYPE is NIL, tries to
195 determine the content type via the file's suffix."
196 ;; the dispatcher
197 (lambda (request)
198 (when (string= (script-name request) uri)
199 ;; the handler
200 (lambda ()
201 (handle-static-file path content-type)))))
202
203 (defun create-folder-dispatcher-and-handler (uri-prefix base-path &optional content-type)
204 "Creates and returns a dispatch function which will dispatch to a
205 handler function which emits the file relative to BASE-PATH that is
206 denoted by the URI of the request relative to URI-PREFIX. URI-PREFIX
207 must be a string ending with a slash, BASE-PATH must be a pathname
208 designator for an existing directory. If CONTENT-TYPE is not NIL,
209 it'll be the content type used for all files in the folder."
210 (unless (and (stringp uri-prefix)
211 (plusp (length uri-prefix))
212 (char= (char uri-prefix (1- (length uri-prefix))) #\/))
213 (parameter-error "~S must be string ending with a slash." uri-prefix))
214 (unless (fad:directory-pathname-p base-path)
215 (parameter-error "~S is supposed to denote a directory." base-path))
216 (flet ((handler ()
217 (let ((request-path (request-pathname *request* uri-prefix)))
218 (when (null request-path)
219 (setf (return-code*) +http-forbidden+)
220 (abort-request-handler))
221 (handle-static-file (merge-pathnames request-path base-path) content-type))))
222 (create-prefix-dispatcher uri-prefix #'handler)))
223
224 (defun no-cache ()
225 "Adds appropriate headers to completely prevent caching on most browsers."
226 (setf (header-out :expires)
227 "Mon, 26 Jul 1997 05:00:00 GMT"
228 (header-out :cache-control)
229 "no-store, no-cache, must-revalidate, post-check=0, pre-check=0"
230 (header-out :pragma)
231 "no-cache"
232 (header-out :last-modified)
233 (rfc-1123-date))
234 (values))
235
236 (defun redirect (target &key (host (host *request*) host-provided-p)
237 port
238 (protocol (if (ssl-p) :https :http))
239 (add-session-id (not (or host-provided-p
240 (starts-with-scheme-p target)
241 (cookie-in (session-cookie-name *acceptor*)))))
242 (code +http-moved-temporarily+))
243 "Redirects the browser to TARGET which should be a string. If
244 TARGET is a full URL starting with a scheme, HOST, PORT and PROTOCOL
245 are ignored. Otherwise, TARGET should denote the path part of a URL,
246 PROTOCOL must be one of the keywords :HTTP or :HTTPS, and the URL to
247 redirect to will be constructed from HOST, PORT, PROTOCOL, and TARGET.
248 Adds a session ID if ADD-SESSION-ID is true. If CODE is a 3xx
249 redirection code, it will be sent as status code."
250 (check-type code (integer 300 399))
251 (let ((url (if (starts-with-scheme-p target)
252 target
253 (format nil "~A://~A~@[:~A~]~A"
254 (ecase protocol
255 ((:http) "http")
256 ((:https) "https"))
257 (if port
258 (first (ppcre:split ":" (or host "")))
259 host)
260 port target))))
261 (when add-session-id
262 (setq url (add-cookie-value-to-url url :replace-ampersands-p nil)))
263 (setf (header-out :location) url
264 (return-code*) code)
265 (abort-request-handler)))
266
267 (defun require-authorization (&optional (realm "Hunchentoot"))
268 "Sends back appropriate headers to require basic HTTP authentication
269 \(see RFC 2617) for the realm REALM."
270 (setf (header-out :www-authenticate)
271 (format nil "Basic realm=\"~A\"" (quote-string realm))
272 (return-code *reply*)
273 +http-authorization-required+)
274 (abort-request-handler))