test-handlers.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-test)
30
31 (defvar *this-file* (load-time-value
32 (or #.*compile-file-pathname* *load-pathname*)))
33
34 (defmacro with-html (&body body)
35 `(with-html-output-to-string (*standard-output* nil :prologue t)
36 ,@body))
37
38 (defun hunchentoot-link ()
39 (with-html-output (*standard-output*)
40 (:a :href "http://weitz.de/hunchentoot/" "Hunchentoot")))
41
42 (defun menu-link ()
43 (with-html-output (*standard-output*)
44 (:p (:hr
45 (:a :href "/hunchentoot/test" "Back to menu")))))
46
47 (defmacro with-lisp-output ((var) &body body)
48 `(let ((*package* (find-package :hunchentoot-test-user)))
49 (with-output-to-string (,var #+:lispworks nil
50 #+:lispworks :element-type
51 #+:lispworks 'lw:simple-char)
52 ,@body)))
53
54 (defmacro info-table (&rest forms)
55 (let ((=value= (gensym))
56 (=first= (gensym)))
57 `(with-html-output (*standard-output*)
58 (:p (:table :border 1 :cellpadding 2 :cellspacing 0
59 (:tr (:td :colspan 2
60 "Some Information "
61 (hunchentoot-link)
62 " provides about this request:"))
63 ,@(loop for form in forms
64 collect `(:tr (:td :valign "top"
65 (:pre :style "padding: 0px"
66 (esc (with-lisp-output (s) (pprint ',form s)))))
67 (:td :valign "top"
68 (:pre :style "padding: 0px"
69 (esc (with-lisp-output (s)
70 (loop for ,=value= in (multiple-value-list ,form)
71 for ,=first= = t then nil
72 unless ,=first=
73 do (princ ", " s)
74 do (pprint ,=value= s))))))))))
75 (menu-link))))
76
77 (defun authorization-page ()
78 (multiple-value-bind (user password)
79 (authorization)
80 (cond ((and (equal user "nanook")
81 (equal password "igloo"))
82 (with-html
83 (:html
84 (:head (:title "Hunchentoot page with Basic Authentication"))
85 (:body
86 (:h2 (hunchentoot-link)
87 " page with Basic Authentication")
88 (info-table (header-in* :authorization)
89 (authorization))))))
90 (t
91 (require-authorization)))))
92
93 (defparameter *test-image*
94 (load-time-value
95 (with-open-file (in (make-pathname :name "fz" :type "jpg" :version nil
96 :defaults *this-file*)
97 :element-type 'flex:octet)
98 (let ((image-data (make-array (file-length in)
99 :element-type 'flex:octet)))
100 (read-sequence image-data in)
101 image-data))))
102
103 (defun image-ram-page ()
104 (setf (content-type*) "image/jpeg")
105 *test-image*)
106
107 (let ((count 0))
108 (defun info ()
109 (with-html
110 (:html
111 (:head (:title "Hunchentoot Information"))
112 (:body
113 (:h2 (hunchentoot-link) " Information Page")
114 (:p "This page has been called "
115 (:b
116 (fmt "~[~;once~;twice~:;~:*~R times~]" (incf count)))
117 " since its handler was compiled.")
118 (info-table (host)
119 (acceptor-address *acceptor*)
120 (acceptor-port *acceptor*)
121 (remote-addr*)
122 (remote-port*)
123 (real-remote-addr)
124 (request-method*)
125 (script-name*)
126 (query-string*)
127 (get-parameters*)
128 (headers-in*)
129 (cookies-in*)
130 (user-agent)
131 (referer)
132 (request-uri*)
133 (server-protocol*)))))))
134
135 (defun oops ()
136 (with-html
137 (log-message* :error "Oops \(error log level).")
138 (log-message* :warning "Oops \(warning log level).")
139 (log-message* :info "Oops \(info log level).")
140 (error "Errors were triggered on purpose. Check your error log.")
141 (:html
142 (:body "You should never see this sentence..."))))
143
144 (defun redir ()
145 (redirect "/hunchentoot/test/info.html?redirected=1"))
146
147 (defun forbidden ()
148 (setf (return-code*) +http-forbidden+)
149 nil)
150
151 (defun cookie-test ()
152 (set-cookie "pumpkin" :value "barking")
153 (no-cache)
154 (with-html
155 (:html
156 (:head (:title "Hunchentoot cookie test"))
157 (:body
158 (:h2 (hunchentoot-link)
159 " cookie test")
160 (:p "You might have to reload this page to see the cookie value.")
161 (info-table (cookie-in "pumpkin")
162 (mapcar 'car (cookies-in*)))))))
163
164 (defun session-test ()
165 (let ((new-foo-value (post-parameter "new-foo-value")))
166 (when new-foo-value
167 (setf (session-value 'foo) new-foo-value)))
168 (let ((new-bar-value (post-parameter "new-bar-value")))
169 (when new-bar-value
170 (setf (session-value 'bar) new-bar-value)))
171 (no-cache)
172 (with-html
173 (:html
174 (:head (:title "Hunchentoot session test"))
175 (:body
176 (:h2 (hunchentoot-link)
177 " session test")
178 (:p "Use the forms below to set new values for "
179 (:code "FOO")
180 " or "
181 (:code "BAR")
182 ". You can later return to this page to check if
183 they're still set. Also, try to use another browser at the same
184 time or try with cookies disabled.")
185 (:p (:form :method :post
186 "New value for "
187 (:code "FOO")
188 ": "
189 (:input :type :text
190 :name "new-foo-value"
191 :value (or (session-value 'foo) ""))))
192 (:p (:form :method :post
193 "New value for "
194 (:code "BAR")
195 ": "
196 (:input :type :text
197 :name "new-bar-value"
198 :value (or (session-value 'bar) ""))))
199 (info-table (session-cookie-name *acceptor*)
200 (cookie-in (session-cookie-name *acceptor*))
201 (mapcar 'car (cookies-in*))
202 (session-value 'foo)
203 (session-value 'bar))))))
204
205 (defun parameter-test (&key (method :get) (charset :iso-8859-1))
206 (no-cache)
207 (recompute-request-parameters :external-format
208 (flex:make-external-format charset :eol-style :lf))
209 (setf (content-type*)
210 (format nil "text/html; charset=~A" charset))
211 (with-html
212 (:html
213 (:head (:title (fmt "Hunchentoot ~A parameter test" method)))
214 (:body
215 (:h2 (hunchentoot-link)
216 (fmt " ~A parameter test with charset ~A" method charset))
217 (:p "Enter some non-ASCII characters in the input field below
218 and see what's happening.")
219 (:p (:form
220 :method method
221 "Enter a value: "
222 (:input :type :text
223 :name "foo")))
224 (case method
225 (:get (info-table (query-string*)
226 (map 'list 'char-code (get-parameter "foo"))
227 (get-parameter "foo")))
228 (:post (info-table (raw-post-data)
229 (map 'list 'char-code (post-parameter "foo"))
230 (post-parameter "foo"))))))))
231
232 (defun parameter-test-latin1-get ()
233 (parameter-test :method :get :charset :iso-8859-1))
234
235 (defun parameter-test-latin1-post ()
236 (parameter-test :method :post :charset :iso-8859-1))
237
238 (defun parameter-test-utf8-get ()
239 (parameter-test :method :get :charset :utf-8))
240
241 (defun parameter-test-utf8-post ()
242 (parameter-test :method :post :charset :utf-8))
243
244 ;; this should not be the same directory as *TMP-DIRECTORY* and it
245 ;; should be initially empty (or non-existent)
246 (defvar *tmp-test-directory*
247 #+(or :win32 :mswindows) #p"c:\\hunchentoot-temp\\test\\"
248 #-(or :win32 :mswindows) #p"/tmp/hunchentoot/test/")
249
250 (defvar *tmp-test-files* nil)
251
252 (let ((counter 0))
253 (defun handle-file (post-parameter)
254 (when (and post-parameter
255 (listp post-parameter))
256 (destructuring-bind (path file-name content-type)
257 post-parameter
258 (let ((new-path (make-pathname :name (format nil "hunchentoot-test-~A"
259 (incf counter))
260 :type nil
261 :defaults *tmp-test-directory*)))
262 ;; strip directory info sent by Windows browsers
263 (when (search "Windows" (user-agent) :test 'char-equal)
264 (setq file-name (cl-ppcre:regex-replace ".*\\\\" file-name "")))
265 (rename-file path (ensure-directories-exist new-path))
266 (push (list new-path file-name content-type) *tmp-test-files*))))))
267
268 (defun clean-tmp-dir ()
269 (loop for (path . nil) in *tmp-test-files*
270 when (probe-file path)
271 do (ignore-errors (delete-file path)))
272 (setq *tmp-test-files* nil))
273
274 (defun upload-test ()
275 (let (post-parameter-p)
276 (when (post-parameter "file1")
277 (handle-file (post-parameter "file1"))
278 (setq post-parameter-p t))
279 (when (post-parameter "file2")
280 (handle-file (post-parameter "file2"))
281 (setq post-parameter-p t))
282 (when (post-parameter "clean")
283 (clean-tmp-dir)
284 (setq post-parameter-p t)))
285 (no-cache)
286 (with-html
287 (:html
288 (:head (:title "Hunchentoot file upload test"))
289 (:body
290 (:h2 (hunchentoot-link)
291 " file upload test")
292 (:form :method :post :enctype "multipart/form-data"
293 (:p "First file: "
294 (:input :type :file
295 :name "file1"))
296 (:p "Second file: "
297 (:input :type :file
298 :name "file2"))
299 (:p (:input :type :submit)))
300 (when *tmp-test-files*
301 (htm
302 (:p
303 (:table :border 1 :cellpadding 2 :cellspacing 0
304 (:tr (:td :colspan 3 (:b "Uploaded files")))
305 (loop for (path file-name nil) in *tmp-test-files*
306 for counter from 1
307 do (htm
308 (:tr (:td :align "right" (str counter))
309 (:td (:a :href (format nil "files/~A?path=~A"
310 (url-encode file-name)
311 (url-encode (namestring path)))
312 (esc file-name)))
313 (:td :align "right"
314 (str (ignore-errors
315 (with-open-file (in path)
316 (file-length in))))
317 " Bytes"))))))
318 (:form :method :post
319 (:p (:input :type :submit :name "clean" :value "Delete uploaded files")))))
320 (menu-link)))))
321
322 (defun send-file ()
323 (let* ((path (get-parameter "path"))
324 (file-info (and path
325 (find path *tmp-test-files*
326 :key 'first :test (lambda (a b) (equal a (namestring b)))))))
327 (unless file-info
328 (setf (return-code*) +http-not-found+)
329 (return-from send-file))
330 (handle-static-file (first file-info) (third file-info))))
331
332 (defparameter *headline*
333 (load-time-value
334 (format nil "Hunchentoot test menu (see file <code>~A</code>)"
335 (truename (merge-pathnames (make-pathname :type "lisp") *this-file*)))))
336
337 (defvar *utf-8* (flex:make-external-format :utf-8 :eol-style :lf))
338
339 (defvar *utf-8-file* (merge-pathnames "UTF-8-demo.html" *this-file*)
340 "Demo file stolen from <http://www.w3.org/2001/06/utf-8-test/>.")
341
342 (defun stream-direct ()
343 (setf (content-type*) "text/html; charset=utf-8")
344 (let ((stream (send-headers))
345 (buffer (make-array 1024 :element-type 'flex:octet)))
346 (with-open-file (in *utf-8-file* :element-type 'flex:octet)
347 (loop for pos = (read-sequence buffer in)
348 until (zerop pos)
349 do (write-sequence buffer stream :end pos)))))
350
351 (defun stream-direct-utf-8 ()
352 (setf (content-type*) "text/html; charset=utf-8")
353 (let ((stream (flex:make-flexi-stream (send-headers) :external-format *utf-8*)))
354 (with-open-file (in (merge-pathnames "UTF-8-demo.html" *this-file*)
355 :element-type 'flex:octet)
356 (setq in (flex:make-flexi-stream in :external-format *utf-8*))
357 (loop for line = (read-line in nil nil)
358 while line
359 do (write-line line stream)))))
360
361 (defun stream-direct-utf-8-string ()
362 (setf (content-type*) "text/html; charset=utf-8"
363 (reply-external-format*) *utf-8*)
364 (with-open-file (in (merge-pathnames "UTF-8-demo.html" *this-file*)
365 :element-type 'flex:octet)
366 (let ((string (make-array (file-length in)
367 :element-type #-:lispworks 'character #+:lispworks 'lw:simple-char
368 :fill-pointer t)))
369 (setf in (flex:make-flexi-stream in :external-format *utf-8*)
370 (fill-pointer string) (read-sequence string in))
371 string)))
372
373 (define-easy-handler (easy-demo :uri "/hunchentoot/test/easy-demo.html"
374 :default-request-type :post)
375 (first-name last-name
376 (age :parameter-type 'integer)
377 (implementation :parameter-type 'keyword)
378 (meal :parameter-type '(hash-table boolean))
379 (team :parameter-type 'list))
380 (with-html
381 (:html
382 (:head (:title "Hunchentoot \"easy\" handler example"))
383 (:body
384 (:h2 (hunchentoot-link)
385 " \"Easy\" handler example")
386 (:p (:form :method :post
387 (:table :border 1 :cellpadding 2 :cellspacing 0
388 (:tr
389 (:td "First Name:")
390 (:td (:input :type :text
391 :name "first-name"
392 :value (or first-name "Donald"))))
393 (:tr
394 (:td "Last name:")
395 (:td (:input :type :text
396 :name "last-name"
397 :value (or last-name "Duck"))))
398 (:tr
399 (:td "Age:")
400 (:td (:input :type :text
401 :name "age"
402 :value (or age 42))))
403 (:tr
404 (:td "Implementation:")
405 (:td (:select :name "implementation"
406 (loop for (value option) in '((:lispworks "LispWorks")
407 (:allegro "AllegroCL")
408 (:cmu "CMUCL")
409 (:sbcl "SBCL")
410 (:openmcl "OpenMCL"))
411 do (htm
412 (:option :value value
413 :selected (eq value implementation)
414 (str option)))))))
415 (:tr
416 (:td :valign :top "Meal:")
417 (:td (loop for choice in '("Burnt weeny sandwich"
418 "Canard du jour"
419 "Easy meat"
420 "Muffin"
421 "Twenty small cigars"
422 "Yellow snow")
423 do (htm
424 (:input :type "checkbox"
425 :name (format nil "meal{~A}" choice)
426 :checked (gethash choice meal)
427 (esc choice))
428 (:br)))))
429 (:tr
430 (:td :valign :top "Team:")
431 (:td (loop for player in '("Beckenbauer"
432 "Cruyff"
433 "Maradona"
434 ;; without accent (for SBCL)
435 "Pele"
436 "Zidane")
437 do (htm
438 (:input :type "checkbox"
439 :name "team"
440 :value player
441 :checked (member player team :test 'string=)
442 (esc player))
443 (:br)))))
444 (:tr
445 (:td :colspan 2
446 (:input :type "submit"))))))
447 (info-table first-name
448 last-name
449 age
450 implementation
451 (loop :for choice :being :the :hash-keys :of meal :collect choice)
452 (gethash "Yellow snow" meal)
453 team)))))
454
455
456 (defun menu ()
457 (with-html
458 (:html
459 (:head
460 (:link :rel "shortcut icon"
461 :href "/hunchentoot/test/favicon.ico" :type "image/x-icon")
462 (:title "Hunchentoot test menu"))
463 (:body
464 (:h2 (str *headline*))
465 (:table :border 0 :cellspacing 4 :cellpadding 4
466 (:tr (:td (:a :href "/hunchentoot/test/info.html?foo=bar"
467 "Info provided by Hunchentoot")))
468 (:tr (:td (:a :href "/hunchentoot/test/cookie.html"
469 "Cookie test")))
470 (:tr (:td (:a :href "/hunchentoot/test/session.html"
471 "Session test")))
472 (:tr (:td (:a :href "/hunchentoot/test/parameter_latin1_get.html"
473 "GET parameter handling with LATIN-1 charset")))
474 (:tr (:td (:a :href "/hunchentoot/test/parameter_latin1_post.html"
475 "POST parameter handling with LATIN-1 charset")))
476 (:tr (:td (:a :href "/hunchentoot/test/parameter_utf8_get.html"
477 "GET parameter handling with UTF-8 charset")))
478 (:tr (:td (:a :href "/hunchentoot/test/parameter_utf8_post.html"
479 "POST parameter handling with UTF-8 charset")))
480 (:tr (:td (:a :href "/hunchentoot/test/redir.html"
481 "Redirect \(302) to info page above")))
482 (:tr (:td (:a :href "/hunchentoot/test/authorization.html"
483 "Authorization")
484 " (user 'nanook', password 'igloo')"))
485 (:tr (:td (:a :href "/hunchentoot/code/test-handlers.lisp"
486 "The source code of this test")))
487 (:tr (:td (:a :href "/hunchentoot/test/image.jpg"
488 "Binary data, delivered from file")
489 " \(a picture)"))
490 (:tr (:td (:a :href "/hunchentoot/test/image-ram.jpg"
491 "Binary data, delivered from RAM")
492 " \(same picture)"))
493 (:tr (:td (:a :href "/hunchentoot/test/easy-demo.html"
494 "\"Easy\" handler example")))
495 (:tr (:td (:a :href "/hunchentoot/test/utf8-binary.txt"
496 "UTF-8 demo")
497 " \(writing octets directly to the stream)"))
498 (:tr (:td (:a :href "/hunchentoot/test/utf8-character.txt"
499 "UTF-8 demo")
500 " \(writing UTF-8 characters directly to the stream)"))
501 (:tr (:td (:a :href "/hunchentoot/test/utf8-string.txt"
502 "UTF-8 demo")
503 " \(returning a string)"))
504 (:tr (:td (:a :href "/hunchentoot/test/upload.html"
505 "File uploads")))
506 (:tr (:td (:a :href "/hunchentoot/test/forbidden.html"
507 "Forbidden \(403) page")))
508 (:tr (:td (:a :href "/hunchentoot/test/oops.html"
509 "Error handling")
510 " \(output depends on "
511 (:a :href "http://weitz.de/hunchentoot/#*show-lisp-errors-p*"
512 (:code "*SHOW-LISP-ERRORS-P*"))
513 (fmt " \(currently ~S))" *show-lisp-errors-p*)))
514 (:tr (:td (:a :href "/hunchentoot/foo"
515 "URI handled by")
516 " "
517 (:a :href "http://weitz.de/hunchentoot/#*default-handler*"
518 (:code "*DEFAULT-HANDLER*")))))))))
519
520 (setq *dispatch-table*
521 (nconc
522 (list 'dispatch-easy-handlers
523 (create-static-file-dispatcher-and-handler
524 "/hunchentoot/test/image.jpg"
525 (make-pathname :name "fz" :type "jpg" :version nil
526 :defaults *this-file*)
527 "image/jpeg")
528 (create-static-file-dispatcher-and-handler
529 "/hunchentoot/test/favicon.ico"
530 (make-pathname :name "favicon" :type "ico" :version nil
531 :defaults *this-file*))
532 (create-folder-dispatcher-and-handler
533 "/hunchentoot/code/"
534 (make-pathname :name nil :type nil :version nil
535 :defaults *this-file*)
536 "text/plain"))
537 (mapcar (lambda (args)
538 (apply 'create-prefix-dispatcher args))
539 '(("/hunchentoot/test/form-test.html" form-test)
540 ("/hunchentoot/test/forbidden.html" forbidden)
541 ("/hunchentoot/test/info.html" info)
542 ("/hunchentoot/test/authorization.html" authorization-page)
543 ("/hunchentoot/test/image-ram.jpg" image-ram-page)
544 ("/hunchentoot/test/cookie.html" cookie-test)
545 ("/hunchentoot/test/session.html" session-test)
546 ("/hunchentoot/test/parameter_latin1_get.html" parameter-test-latin1-get)
547 ("/hunchentoot/test/parameter_latin1_post.html" parameter-test-latin1-post)
548 ("/hunchentoot/test/parameter_utf8_get.html" parameter-test-utf8-get)
549 ("/hunchentoot/test/parameter_utf8_post.html" parameter-test-utf8-post)
550 ("/hunchentoot/test/upload.html" upload-test)
551 ("/hunchentoot/test/redir.html" redir)
552 ("/hunchentoot/test/oops.html" oops)
553 ("/hunchentoot/test/utf8-binary.txt" stream-direct)
554 ("/hunchentoot/test/utf8-character.txt" stream-direct-utf-8)
555 ("/hunchentoot/test/utf8-string.txt" stream-direct-utf-8-string)
556 ("/hunchentoot/test/files/" send-file)
557 ("/hunchentoot/test" menu)))))