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   (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                        "&nbsp;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 'second :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)))))