-
Notifications
You must be signed in to change notification settings - Fork 0
/
web.lisp
146 lines (127 loc) · 4.96 KB
/
web.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
(in-package :com.gigamonkeys.web)
(defun random-number (request entity)
(with-http-response (request entity :content-type "text/html")
(with-http-body (request entity)
(with-html-output ((request-reply-stream request))
(let* ((limit-string (or (request-query-value "limit" request) ""))
(limit (or (parse-integer limit-string :junk-allowed t) 1000)))
(html
(:html
(:head (:title "Random"))
(:body
(:p "Random number: " (:print (random limit)))))))))))
(define-html-macro :standard-page ((&key title) &body body)
`(:html
(:head (:title ,title))
(:body
(:h1 ,title)
,@body)))
(defun show-query-params (request entity)
(with-http-response (request entity :content-type "text/html")
(with-http-body (request entity)
(with-html-output ((request-reply-stream request))
(html
(:standard-page
(:title "Query Parameters")
(if (request-query request)
(html
(:table :border 1
(loop for (k . v) in (request-query request)
do (html (:tr (:td k) (:td v))))))
(html (:p "No query parameters.")))))))))
(defun simple-form (request entity)
(with-http-response (request entity :content-type "text/html")
(with-http-body (request entity)
(with-html-output ((request-reply-stream request))
(html
(: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"))))))))))
(defun show-cookies (request entity)
(with-http-response (request entity :content-type "text/html")
(with-http-body (request entity)
(with-html-output ((request-reply-stream request))
(html
(:standard-page
(:title "Cookies")
(if (null (get-cookie-values request))
(html (:p "No cookies."))
(html
(:table
(loop for (key . value) in (get-cookie-values request)
do (html (:tr (:td key) (:td value)))))))))))))
(defun set-cookie (request entity)
(with-http-response (request entity :content-type "text/html")
(set-cookie-header request :name "MyCookie" :value "a cookie value")
(with-http-body (request entity)
(with-html-output ((request-reply-stream request))
(html
(:standard-page
(:title "Set Cookie")
(:p "Cookie set.")
(:p (:a :href "/show-cookies" "Look at cookie jar."))))))))
(defmacro define-url-function (name (request &rest params) &body body)
(with-gensyms (entity)
(let ((params (mapcar #'normalize-param params)))
`(progn
(defun ,name (,request ,entity)
(with-http-response (,request ,entity :content-type "text/html")
(let* (,@(param-bindings name request params))
,@(set-cookies-code name request params)
(with-http-body (,request ,entity)
(with-html-output ((request-reply-stream ,request))
(html ,@body))))))
(publish :path ,(format nil "/~(~a~)" name) :function ',name)))))
(defun normalize-param (param)
(etypecase param
(list param)
(symbol `(,param string nil nil))))
(defun param-bindings (function-name request params)
(loop for param in params
collect (param-binding function-name request param)))
(defun param-binding (function-name request 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 ,request))
,@(if cookie-name
(list `(string->type ',type
(get-cookie-value ,request ,cookie-name))))
,default)))))
(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 (request name)
(cdr (assoc name (get-cookie-values request) :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-cookies-code (function-name request params)
(loop for param in params
when (set-cookie-code function-name request param) collect it))
(defun set-cookie-code (function-name request param)
(destructuring-bind (name type &optional default stickie) param
(declare (ignore type default))
(if stickie
`(when ,name
(set-cookie-header
,request
:name ,(symbol->cookie-name function-name name stickie)
:value (princ-to-string ,name))))))