(in-package :cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :hunchentoot)
(require :cl-who))
(defpackage :web-test
(:use :common-lisp :hunchentoot :cl-who :iter))
(in-package :web-test)
(start-server :port 2001)
(setf *dispatch-table*
(list (create-static-file-dispatcher-and-handler
"/hello.html" "/tmp/html/hello.html")))
(setf *dispatch-table*
(list (create-folder-dispatcher-and-handler
"/" "/tmp/html/")))
(defun random-number ()
(format nil
"<html>~@
<head><title>Random</title></head>~@
<body>~@
<p>Random number: ~d</p>~@
</body>~@
</html>~@
"
(random 1000)))
(setf *dispatch-table*
(list (create-regex-dispatcher "/random-number" #'random-number)))
(defun random-number ()
(with-html-output-to-string (*standard-output*)
(:html (:head (:title "Random"))
(:body (:p "Random number: " (write (random 1000)))))))
(setf *dispatch-table*
(list (create-regex-dispatcher "/random-number" #'random-number)))
(defun show-query-params ()
(let ((parameters (append (get-parameters) (post-parameters))))
(with-html-output-to-string (*standard-output*)
(:html (:head (:title "Query Parameters"))
(:body (if parameters
(htm (:table :border 1
(iter (for (k . v) in parameters)
(htm (:tr (:td (str k))
(:td (str v)))))))
(htm (:p "No query parameters."))))))))
(setf *dispatch-table*
(list (create-regex-dispatcher "/show-query-params"
#'show-query-params)))
(defun simple-form ()
(with-html-output-to-string (*standard-output*)
(:html
(:head (:title "Simple Form"))
(:body
(:form :method "POST" :action "/show-query-params"
(:table
(:tr (:td "Foo")
(:td (:input :name "foo" :size 20)))
(:tr (:td "Password")
(:td (:input :name "password" :type "password" :size 20))))
(:p (:input :name "submit" :type "submit" :value "Okay")
(:input :type "reset" :value "Reset")))))))
(push (create-regex-dispatcher "/simple-form" #'simple-form) *dispatch-table*)
(defun random-number ()
(let* ((limit-string (cdr (assoc "limit" (get-parameters) :test #'string=)))
(limit (or (and limit-string (parse-integer limit-string
:junk-allowed t))
1000)))
(with-html-output-to-string (*standard-output*)
(:html (:head (:title "Random"))
(:body (:p "Random number: " (write (random limit))))))))
(setf *dispatch-table*
(list (create-regex-dispatcher "/random-number" #'random-number)))
(defun show-cookies ()
(let ((cookies (cookies-in)))
(with-html-output-to-string (*standard-output*)
(:html (:head (:title "Cookies"))
(:body (if cookies
(htm (:table (iter (for (key . value) in cookies)
(htm (:tr (:td (str key))
(:td (str value)))))))
(htm (:p "No cookies."))))))))
(defun set-my-cookie ()
(set-cookie "MyCookie" :value "A cookie value")
(with-html-output-to-string (*standard-output*)
(:html (:head (:title "Set Cookie"))
(:body (:p "Cookie set.")
(:p (:a :href "/show-cookies" "Look at cookie jar."))))))
(setf *dispatch-table*
(list (create-regex-dispatcher "/show-cookies" #'show-cookies)
(create-regex-dispatcher "/set-cookie" #'set-my-cookie)))
(defgeneric string->type (type value))
(defmethod string->type ((type (eql 'string)) value)
(and (plusp (length value)) value))
(defmethod string->type ((type (eql 'integer)) value)
(parse-integer (or value "") :junk-allowed t))
(defun get-cookie-value (name)
(cdr (assoc name (cookies-in) :test #'string=)))
(defun symbol->query-name (sym)
(string-downcase sym))
(defun symbol->cookie-name (function-name sym sticky)
(let ((package-name (package-name (symbol-package function-name))))
(when sticky
(ecase sticky
(:global
(string-downcase sym))
(:package
(format nil "~(~a:~a~)" package-name sym))
(:local
(format nil "~(~a:~a:~a~)" package-name function-name sym))))))
(defun set-cookie-code (function-name param)
(destructuring-bind (name type &optional default sticky) param
(declare (ignore type default))
(if sticky
`(when ,name
(set-cookie ,(symbol->cookie-name function-name name sticky)
:value (princ-to-string ,name))))))
(defun set-cookies-code (function-name params)
(iter (for param in params)
(for code = (set-cookie-code function-name param))
(when code (collect code))))
(defun normalize-param (param)
(etypecase param
(list param)
(symbol `(,param string nil nil))))
(defun request-query-value (query-name)
(cdr (assoc query-name (get-parameters) :test #'string=)))
(defun param-binding (function-name param)
(destructuring-bind (name type &optional default sticky) param
(let ((query-name (symbol->query-name name))
(cookie-name (symbol->cookie-name function-name name sticky)))
`(,name (or
(string->type ',type (request-query-value ,query-name))
,@(if cookie-name
(list `(string->type ',type
(get-cookie-value ,cookie-name))))
,default)))))
(defun param-bindings (function-name params)
(iter (for param in params)
(collect (param-binding function-name param))))
(defmacro define-url-function (name (&rest params) &body body)
(let ((params (mapcar #'normalize-param params)))
`(progn
(defun ,name ()
(let* (,@(param-bindings name params))
,@(set-cookies-code name params)
(with-html-output-to-string (*standard-output*)
,@body)))
(push (create-regex-dispatcher ,(format nil "/~(~a~)" name) #',name)
*dispatch-table*))))
(define-url-function random-number ((limit integer 1000))
(:html (:head (:title "Random"))
(:body (:p (fmt "Random number: ~d" (random limit))))))