test/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     (when post-parameter-p
 286       ;; redirect so user can safely use 'Back' button
 287       (redirect (script-name*))))
 288   (no-cache)
 289   (with-html
 290     (:html
 291      (:head (:title "Hunchentoot file upload test"))
 292      (:body
 293       (:h2 (hunchentoot-link)
 294        " file upload test")
 295       (:form :method :post :enctype "multipart/form-data"
 296        (:p "First file: "
 297         (:input :type :file
 298          :name "file1"))
 299        (:p "Second file: "
 300         (:input :type :file
 301          :name "file2"))
 302        (:p (:input :type :submit)))
 303       (when *tmp-test-files*
 304         (htm
 305          (:p
 306           (:table :border 1 :cellpadding 2 :cellspacing 0
 307            (:tr (:td :colspan 3 (:b "Uploaded files")))
 308            (loop for (path file-name nil) in *tmp-test-files*
 309                  for counter from 1
 310                  do (htm
 311                      (:tr (:td :align "right" (str counter))
 312                       (:td (:a :href (format nil "files/~A?path=~A"
 313                                              (url-encode file-name)
 314                                              (url-encode (namestring path)))
 315                             (esc file-name)))
 316                       (:td :align "right"
 317                        (str (ignore-errors
 318                               (with-open-file (in path)
 319                                 (file-length in))))
 320                        "&nbsp;Bytes"))))))
 321          (:form :method :post
 322           (:p (:input :type :submit :name "clean" :value "Delete uploaded files")))))
 323       (menu-link)))))
 324
 325 (defun send-file ()
 326   (let* ((path (get-parameter "path"))
 327          (file-info (and path
 328                          (find path *tmp-test-files*
 329                                :key 'second :test 'equal))))
 330     (unless file-info
 331       (setf (return-code*) +http-not-found+)
 332       (return-from send-file))
 333     (handle-static-file (first file-info) (third file-info))))
 334
 335 (defparameter *headline*
 336   (load-time-value
 337    (format nil "Hunchentoot test menu (see file <code>~A</code>)"
 338            (truename (merge-pathnames (make-pathname :type "lisp") *this-file*)))))
 339
 340 (defvar *utf-8* (flex:make-external-format :utf-8 :eol-style :lf))
 341
 342 (defvar *utf-8-file* (merge-pathnames "UTF-8-demo.html" *this-file*)
 343   "Demo file stolen from <http://www.w3.org/2001/06/utf-8-test/>.")
 344
 345 (defun stream-direct ()
 346   (setf (content-type*) "text/html; charset=utf-8")
 347   (let ((stream (send-headers))
 348         (buffer (make-array 1024 :element-type 'flex:octet)))
 349     (with-open-file (in *utf-8-file* :element-type 'flex:octet)
 350       (loop for pos = (read-sequence buffer in)
 351             until (zerop pos)
 352             do (write-sequence buffer stream :end pos)))))
 353
 354 (defun stream-direct-utf-8 ()
 355   (setf (content-type*) "text/html; charset=utf-8")
 356   (let ((stream (flex:make-flexi-stream (send-headers) :external-format *utf-8*)))
 357     (with-open-file (in (merge-pathnames "UTF-8-demo.html" *this-file*)
 358                         :element-type 'flex:octet)
 359       (setq in (flex:make-flexi-stream in :external-format *utf-8*))
 360       (loop for line = (read-line in nil nil)
 361             while line
 362             do (write-line line stream)))))
 363
 364 (defun stream-direct-utf-8-string ()
 365   (setf (content-type*) "text/html; charset=utf-8"
 366         (reply-external-format*) *utf-8*)
 367   (with-open-file (in (merge-pathnames "UTF-8-demo.html" *this-file*)
 368                       :element-type 'flex:octet)
 369     (let ((string (make-array (file-length in)
 370                               :element-type #-:lispworks 'character #+:lispworks 'lw:simple-char
 371                               :fill-pointer t)))
 372       (setf in (flex:make-flexi-stream in :external-format *utf-8*)
 373             (fill-pointer string) (read-sequence string in))
 374       string)))
 375
 376 (define-easy-handler (easy-demo :uri "/hunchentoot/test/easy-demo.html"
 377                                 :default-request-type :post)
 378     (first-name last-name
 379                 (age :parameter-type 'integer)
 380                 (implementation :parameter-type 'keyword)
 381                 (meal :parameter-type '(hash-table boolean))
 382                 (team :parameter-type 'list))
 383   (with-html
 384     (:html
 385      (:head (:title "Hunchentoot \"easy\" handler example"))
 386      (:body
 387       (:h2 (hunchentoot-link)
 388        " \"Easy\" handler example")
 389       (:p (:form :method :post
 390            (:table :border 1 :cellpadding 2 :cellspacing 0
 391             (:tr
 392              (:td "First Name:")
 393              (:td (:input :type :text
 394                    :name "first-name"
 395                    :value (or first-name "Donald"))))
 396             (:tr
 397              (:td "Last name:")
 398              (:td (:input :type :text
 399                    :name "last-name"
 400                    :value (or last-name "Duck"))))
 401             (:tr
 402              (:td "Age:")
 403              (:td (:input :type :text
 404                    :name "age"
 405                    :value (or age 42))))
 406             (:tr
 407              (:td "Implementation:")
 408              (:td (:select :name "implementation"
 409                    (loop for (value option) in '((:lispworks "LispWorks")
 410                                                  (:allegro "AllegroCL")
 411                                                  (:cmu "CMUCL")
 412                                                  (:sbcl "SBCL")
 413                                                  (:openmcl "OpenMCL"))
 414                          do (htm
 415                              (:option :value value
 416                               :selected (eq value implementation)
 417                               (str option)))))))
 418             (:tr
 419              (:td :valign :top "Meal:")
 420              (:td (loop for choice in '("Burnt weeny sandwich"
 421                                         "Canard du jour"
 422                                         "Easy meat"
 423                                         "Muffin"
 424                                         "Twenty small cigars"
 425                                         "Yellow snow")
 426                         do (htm
 427                             (:input :type "checkbox"
 428                              :name (format nil "meal{~A}" choice)
 429                              :checked (gethash choice meal)
 430                              (esc choice))
 431                             (:br)))))
 432             (:tr
 433              (:td :valign :top "Team:")
 434              (:td (loop for player in '("Beckenbauer"
 435                                         "Cruyff"
 436                                         "Maradona"
 437                                         ;; without accent (for SBCL)
 438                                         "Pele"
 439                                         "Zidane")
 440                         do (htm
 441                             (:input :type "checkbox"
 442                              :name "team"
 443                              :value player
 444                              :checked (member player team :test 'string=)
 445                              (esc player))
 446                             (:br)))))
 447             (:tr
 448              (:td :colspan 2
 449               (:input :type "submit"))))))
 450       (info-table first-name
 451                   last-name
 452                   age
 453                   implementation
 454                   (loop :for choice :being :the :hash-keys :of meal :collect choice)
 455                   (gethash "Yellow snow" meal)
 456                   team)))))
 457
 458
 459 (defun menu ()
 460   (with-html
 461     (:html
 462      (:head
 463       (:link :rel "shortcut icon"
 464        :href "/hunchentoot/test/favicon.ico" :type "image/x-icon")
 465       (:title "Hunchentoot test menu"))
 466      (:body
 467       (:h2 (str *headline*))
 468       (:table :border 0 :cellspacing 4 :cellpadding 4
 469        (:tr (:td (:a :href "/hunchentoot/test/info.html?foo=bar"
 470                   "Info provided by Hunchentoot")))
 471        (:tr (:td (:a :href "/hunchentoot/test/cookie.html"
 472                   "Cookie test")))
 473        (:tr (:td (:a :href "/hunchentoot/test/session.html"
 474                   "Session test")))
 475        (:tr (:td (:a :href "/hunchentoot/test/parameter_latin1_get.html"
 476                   "GET parameter handling with LATIN-1 charset")))
 477        (:tr (:td (:a :href "/hunchentoot/test/parameter_latin1_post.html"
 478                   "POST parameter handling with LATIN-1 charset")))
 479        (:tr (:td (:a :href "/hunchentoot/test/parameter_utf8_get.html"
 480                   "GET parameter handling with UTF-8 charset")))
 481        (:tr (:td (:a :href "/hunchentoot/test/parameter_utf8_post.html"
 482                   "POST parameter handling with UTF-8 charset")))
 483        (:tr (:td (:a :href "/hunchentoot/test/redir.html"
 484                   "Redirect \(302) to info page above")))
 485        (:tr (:td (:a :href "/hunchentoot/test/authorization.html"
 486                   "Authorization")
 487              " (user 'nanook', password 'igloo')"))
 488        (:tr (:td (:a :href "/hunchentoot/code/test-handlers.lisp"
 489                   "The source code of this test")))
 490        (:tr (:td (:a :href "/hunchentoot/test/image.jpg"
 491                   "Binary data, delivered from file")
 492              " \(a picture)"))
 493        (:tr (:td (:a :href "/hunchentoot/test/image-ram.jpg"
 494                   "Binary data, delivered from RAM")
 495              " \(same picture)"))
 496        (:tr (:td (:a :href "/hunchentoot/test/easy-demo.html"
 497                   "\"Easy\" handler example")))
 498        (:tr (:td (:a :href "/hunchentoot/test/utf8-binary.txt"
 499                   "UTF-8 demo")
 500              " \(writing octets directly to the stream)"))
 501        (:tr (:td (:a :href "/hunchentoot/test/utf8-character.txt"
 502                   "UTF-8 demo")
 503              " \(writing UTF-8 characters directly to the stream)"))
 504        (:tr (:td (:a :href "/hunchentoot/test/utf8-string.txt"
 505                   "UTF-8 demo")
 506              " \(returning a string)"))
 507        (:tr (:td (:a :href "/hunchentoot/test/upload.html"
 508                   "File uploads")))
 509        (:tr (:td (:a :href "/hunchentoot/test/forbidden.html"
 510                   "Forbidden \(403) page")))
 511        (:tr (:td (:a :href "/hunchentoot/test/oops.html"
 512                   "Error handling")
 513              " \(output depends on "
 514              (:a :href "http://weitz.de/hunchentoot/#*show-lisp-errors-p*"
 515               (:code "*SHOW-LISP-ERRORS-P*"))
 516              (fmt " \(currently ~S))" *show-lisp-errors-p*)))
 517        (:tr (:td (:a :href "/hunchentoot/foo"
 518                   "URI handled by")
 519              " "
 520              (:a :href "http://weitz.de/hunchentoot/#*default-handler*"
 521               (:code "*DEFAULT-HANDLER*")))))))))
 522
 523 (setq *dispatch-table*
 524       (nconc
 525        (list 'dispatch-easy-handlers
 526              (create-static-file-dispatcher-and-handler
 527               "/hunchentoot/test/image.jpg"
 528               (make-pathname :name "fz" :type "jpg" :version nil
 529                              :defaults *this-file*)
 530               "image/jpeg")
 531              (create-static-file-dispatcher-and-handler
 532               "/hunchentoot/test/favicon.ico"
 533               (make-pathname :name "favicon" :type "ico" :version nil
 534                              :defaults *this-file*))
 535              (create-folder-dispatcher-and-handler
 536               "/hunchentoot/code/"
 537               (make-pathname :name nil :type nil :version nil
 538                              :defaults *this-file*)
 539               "text/plain"))
 540        (mapcar (lambda (args)
 541                  (apply 'create-prefix-dispatcher args))
 542                '(("/hunchentoot/test/form-test.html" form-test)
 543                  ("/hunchentoot/test/forbidden.html" forbidden)
 544                  ("/hunchentoot/test/info.html" info)
 545                  ("/hunchentoot/test/authorization.html" authorization-page)
 546                  ("/hunchentoot/test/image-ram.jpg" image-ram-page)
 547                  ("/hunchentoot/test/cookie.html" cookie-test)
 548                  ("/hunchentoot/test/session.html" session-test)
 549                  ("/hunchentoot/test/parameter_latin1_get.html" parameter-test-latin1-get)
 550                  ("/hunchentoot/test/parameter_latin1_post.html" parameter-test-latin1-post)
 551                  ("/hunchentoot/test/parameter_utf8_get.html" parameter-test-utf8-get)
 552                  ("/hunchentoot/test/parameter_utf8_post.html" parameter-test-utf8-post)
 553                  ("/hunchentoot/test/upload.html" upload-test)
 554                  ("/hunchentoot/test/redir.html" redir)
 555                  ("/hunchentoot/test/oops.html" oops)
 556                  ("/hunchentoot/test/utf8-binary.txt" stream-direct)
 557                  ("/hunchentoot/test/utf8-character.txt" stream-direct-utf-8)
 558                  ("/hunchentoot/test/utf8-string.txt" stream-direct-utf-8-string)
 559                  ("/hunchentoot/test/files/" send-file)
 560                  ("/hunchentoot/test" menu)))))