Support dynamic-only virtual hosts by supplying NIL for a VHOST's ROOT.
[mmondor.git] / mmsoftware / cl / server / test-applications.lisp
1 ;;;; $Id: test-applications.lisp,v 1.6 2012/09/14 21:38:55 mmondor Exp $
2
3 #|
4
5 Copyright (c) 2012, Matthew Mondor
6 All rights reserved.
7
8 Redistribution and use in source and binary forms, with or without
9 modification, are permitted provided that the following conditions
10 are met:
11 1. Redistributions of source code must retain the above copyright
12 notice, this list of conditions and the following disclaimer.
13 2. Redistributions in binary form must reproduce the above copyright
14 notice, this list of conditions and the following disclaimer in the
15 documentation and/or other materials provided with the distribution.
16
17 THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR
18 IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
19 OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
20 IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT,
21 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
22 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
23 USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
24 THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
26 THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27
28 |#
29
30 (declaim (optimize (speed 3) (safety 1) (debug 3)))
31
32 (defpackage :test-applications
33 (:use :cl :server :httpd :html)
34 (:export #:chat-frames
35 #:chat-lines
36 #:chat-prompt
37 #:ne-names
38 #:ne-details))
39
40 (in-package :test-applications)
41
42 (defparameter *rcsid*
43 "$Id: test-applications.lisp,v 1.6 2012/09/14 21:38:55 mmondor Exp $")
44
45
46 ;;; Helper functions
47
48 (defmacro with-temp-file ((path filename) &body body)
49 (let ((tmpfile (gensym)))
50 `(let* ((,tmpfile (ext:mkstemp ,filename))
51 (,path ,tmpfile))
52 (unwind-protect
53 (progn
54 ,@body)
55 (handler-case
56 (delete-file ,tmpfile)
57 (simple-error ()
58 nil))))))
59
60 ;;; XXX Perhaps rename original to .old then move tmpfile to original name.
61 ;;; Also, perhaps provide a thread designed to regularily save data, for
62 ;;; use by such applications... of course, in the long term a DB should
63 ;;; be used.
64 (defun save-list (filename list)
65 (with-temp-file (tmpfile filename)
66 (with-open-file (s tmpfile :direction :output)
67 (write list :stream s)
68 (format s "~%")
69 (finish-output s))
70 (rename-file tmpfile filename :if-exists :supersede)))
71
72 (defun load-list (filename)
73 (handler-case
74 (with-open-file (s filename :direction :input)
75 (read s))
76 (file-error ()
77 '())))
78
79
80 ;;; Test "chat" board with 1024 messages backlog
81
82 (defparameter *chat-lines-file* "/home/mmondor/tmp/chat-lines.lisp")
83 (defparameter *chat-lines-save-interval* 300)
84
85 (defvar *chat-lines-save-lock* (mp:make-lock :name 'chat-lines-save-lock))
86 (defvar *chat-lines*
87 (let ((lines (load-list *chat-lines-file*)))
88 (server::make-fifo :head lines
89 :tail (last lines)
90 :count (length lines)
91 :size 1024)))
92 (defvar *chat-lines-modified* nil)
93
94 (defun chat-save-regularily ()
95 (loop
96 do
97 (handler-case
98 (progn
99 (sleep *chat-lines-save-interval*)
100 (mp:with-lock (*chat-lines-save-lock*)
101 (when *chat-lines-modified*
102 (save-list *chat-lines-file*
103 (server::fifo-head *chat-lines*))
104 (setf *chat-lines-modified* nil))))
105 (t (e)
106 (log-line "# ~A ~A" (type-of e) e)))))
107
108 (defvar *chat-lines-save-thread*
109 (mp:process-run-function 'chat-lines-save-thread #'chat-save-regularily))
110
111 (defun chat-frames (req connection)
112 (declare (ignore req))
113 (http-reply-send
114 (connection-stream connection)
115 (do-html nil
116 (:html
117 (:head
118 (:/link :rel "stylesheet"
119 :href "/css/chat.css"
120 :type "text/css")
121 (:title "Share your comments"))
122 (:body :style "height: 99%"
123 (:table :width "100%" :style "height: 99%"
124 (:tr
125 (:td :width "100%" :height "2%"
126 :align "center" :valign "middle"
127 (:h2 "Share your comments")))
128 (:tr
129 (:td :width "100%" :height "20%"
130 :valign "middle"
131 (:iframe :name "prompt" :src "/chat-prompt"
132 :frameborder "0"
133 :scrolling "no"
134 :width "100%"
135 :height "100%"
136 "Prompt")))
137 (:tr
138 (:td :width "100%" :height "78%" :valign "top"
139 (:iframe :name "lines" :src "/chat-lines"
140 :frameborder "0"
141 :scrolling "auto"
142 :width "100%"
143 :height "100%"
144 "Lines")))))))))
145
146 (defun chat-lines (req connection)
147 (declare (ignore req))
148 (let ((reply (make-http-reply)))
149 (http-reply-header-set-nocache reply)
150 (http-reply-content-add
151 reply
152 (do-html nil
153 (:html (:head
154 (:/link :rel "stylesheet"
155 :href "/css/chat.css"
156 :type "text/css")
157 (:/meta :http-equiv "refresh" :content "15")
158 (:title "Messages"))
159 (:body
160 (do-html-loop (with lines = (reverse (server::fifo-head
161 *chat-lines*))
162 for m in lines
163 for (from when msg) = m)
164 (:table :width "100%"
165 (:tr (:td :width "100%" :align "left"
166 (:b
167 "From: " from
168 ", At: " (server-time-rfc when)
169 " (" (server-time-interval
170 (- (server-time) when)) " ago)")))
171 (:tr (:td :width "100%" :align "left"
172 (:pre
173 (html-escape msg))))))))))
174 (http-reply-flush reply (connection-stream connection))))
175
176 (defun chat-prompt (req connection)
177 (with-http-let req
178 ((msg :post :message))
179 (when msg
180 (server::fifo-append
181 *chat-lines*
182 (list (connection-address-string connection)
183 (server-time)
184 msg))
185 (mp:with-lock (*chat-lines-save-lock*)
186 (setf *chat-lines-modified* t))))
187 (http-reply-send
188 (connection-stream connection)
189 (do-html nil
190 (:html (:head
191 (:/link :rel "stylesheet"
192 :href "/css/chat.css"
193 :type "text/css")
194 (:title "Prompt"))
195 (:body :style "height: 99%"
196 (:table :width "100%" :style "height: 93%"
197 (:tr
198 (:td :width "100%" :align "center"
199 (:form :action "/chat-prompt" :method "post"
200 (:textarea :name "message"
201 :rows 5
202 :cols 79
203 "")
204 (:/br)
205 (:/input :type "submit"
206 :value "Post"))))))))))
207
208
209 ;;; Temporary name suggestion+voting application
210
211 (defstruct name-entry
212 (positive (make-hash-table :test #'equal))
213 (negative (make-hash-table :test #'equal)))
214
215 (defparameter *name-entries-file* "/home/mmondor/tmp/name-entries.lisp")
216 (defparameter *name-entries-save-interval* 300)
217
218 (defvar *name-entries-lock* (mp:make-lock :name 'name-entries-lock
219 :recursive t))
220 (defvar *name-entries* (make-hash-table :test #'equalp))
221
222 (defun list<-name-entries ()
223 (mp:with-lock (*name-entries-lock*)
224 (loop
225 for key being each hash-key of *name-entries* using (hash-value val)
226 collect
227 `(,key
228 ,(loop
229 for a being each hash-key of (name-entry-positive val)
230 using (hash-value r)
231 collect `(,a ,r))
232 ,(loop
233 for a being each hash-key of (name-entry-negative val)
234 using (hash-value r)
235 collect `(,a ,r))))))
236
237 (defun name-entries<-list (list)
238 (mp:with-lock (*name-entries-lock*)
239 (loop
240 for l in list
241 for (name positive negative) = l
242 do
243 (let ((ne (make-name-entry)))
244 (mapc #'(lambda (i)
245 (destructuring-bind (address reason) i
246 (setf (gethash address (name-entry-positive ne))
247 reason)))
248 positive)
249 (mapc #'(lambda (i)
250 (destructuring-bind (address reason) i
251 (setf (gethash address (name-entry-negative ne))
252 reason)))
253 negative)
254 (setf (gethash name *name-entries*) ne))))
255 t)
256
257 (defvar *name-entries-modified*
258 (prog1
259 nil
260 (name-entries<-list (load-list *name-entries-file*))))
261
262 (defun name-entries-save-regularily ()
263 (loop
264 do
265 (handler-case
266 (progn
267 (sleep *name-entries-save-interval*)
268 (mp:with-lock (*name-entries-lock*)
269 (when *name-entries-modified*
270 (save-list *name-entries-file* (list<-name-entries))
271 (setf *name-entries-modified* nil))))
272 (t (e)
273 (log-line "# ~A ~A" (type-of e) e)))))
274
275 (defvar *name-entries-save-thread*
276 (mp:process-run-function 'name-entries-save-regularily
277 #'name-entries-save-regularily))
278
279 (defun name-entries-popularity ()
280 (mp:with-lock (*name-entries-lock*)
281 (sort
282 (sort
283 (loop
284 with name-entries = *name-entries*
285 for key being each hash-key of name-entries
286 using (hash-value val)
287 collect `(,key ,(- (hash-table-count (name-entry-positive val))
288 (hash-table-count (name-entry-negative val)))))
289 #'string-lessp :key #'first)
290 #'> :key #'second)))
291
292 (defun name-entry-details (name)
293 (mp:with-lock (*name-entries-lock*)
294 (let ((ne (gethash name *name-entries*)))
295 (unless ne
296 (return-from name-entry-details nil))
297 `(,(loop
298 for a being each hash-key of (name-entry-positive ne)
299 using (hash-value r)
300 collect `(,a ,r))
301 ,(loop
302 for a being each hash-key of (name-entry-negative ne)
303 using (hash-value r)
304 collect `(,a ,r))))))
305
306 (defun name-entry-add (name address reason)
307 (mp:with-lock (*name-entries-lock*)
308 (let ((name-entries *name-entries*))
309 (when (gethash name name-entries)
310 (return-from name-entry-add nil))
311 (let ((ne (make-name-entry)))
312 (setf (gethash name name-entries) ne
313 (gethash address (name-entry-positive ne)) reason
314 *name-entries-modified* t)
315 t))))
316
317 (defun name-entry-vote (name address reason vote)
318 (mp:with-lock (*name-entries-lock*)
319 (let ((ne (gethash name *name-entries*)))
320 (unless ne
321 (return-from name-entry-vote nil))
322 (setf (gethash address (if (eq :positive vote)
323 (name-entry-positive ne)
324 (name-entry-negative ne))) reason
325 *name-entries-modified* t)
326 t)))
327
328 (defun ne-names (req connection)
329 ;; First handle any add/vote
330 (with-http-let req
331 ((action :post :action)
332 (name :post :name)
333 (reason :post :reason)
334 (vote :post :vote))
335 (cond ((and (string= action "add")
336 (> (length name) 0)
337 (> (length reason) 0))
338 (name-entry-add name
339 (connection-address-string connection)
340 reason))
341 ((and (string= action "vote")
342 (> (length name) 0)
343 (> (length reason) 0)
344 (member vote '("positive" "negative") :test #'string=))
345 (name-entry-vote name
346 (connection-address-string connection)
347 reason
348 (if (string= "positive" vote)
349 :positive :negative)))))
350 (http-reply-send
351 (connection-stream connection)
352 (do-html nil
353 (:html (:head
354 (:/link :rel "stylesheet"
355 :href "/css/chat.css"
356 :type "text/css")
357 (:title "Suggest a name for this HTTPd"))
358 (:body
359 (:h1 "Suggest a name for this HTTPd")
360 (:a :href "http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
361 :target "_blank"
362 "(source code of the server)")
363 (:/br)(:/br)
364 (:h1 "Important notice")
365 (:p (:b "The name of this HTTP/web server has been chosen. "
366 "The one that was retained is \"Crow\". ")
367 "Crow is of course the name of a smart bird, but also "
368 "that of a Native American nation. As such, the name "
369 "remains in theme with some other web server names "
370 "such as Apache. Moreover, a logo should be rather "
371 "easy to devise from either the silhouette of a crow "
372 "bird or of one of its feathers.")
373 (:p "Thanks to everyone who participated!")
374 (:p "As this is one of the few existing applications "
375 "running under Crow, it will keep running for a while, "
376 "still.")
377 (:h1 "Suggest another name")
378 (:form :action "/names" :method "post"
379 (:/input :type "hidden" :name "action" :value "add")
380 (:table
381 (:tr
382 (:td :align "right" "Name")
383 (:td (:/input :type "text"
384 :name "name"
385 :value ""
386 :maxlength "32"
387 :size "32"))
388 (:td :align "right" "Reason")
389 (:td (:/input :type "text"
390 :name "reason"
391 :value ""
392 :maxlength "64"
393 :size "32"))
394 (:td (:/input :type "submit"
395 :value "Submit")))))
396 (:h1 "Current suggestions by popularity")
397 (:p "Click on a name to view more details.")
398 (:table :cellspacing "10"
399 (:tr
400 (:th :align "left" "Name") (:th "Points") (:th "Vote"))
401 (do-html-loop (for (name points) in (name-entries-popularity)
402 for uname = (url-encode name)
403 for hname = (html-escape name))
404 (:tr
405 (:td (:a :href (concatenate 'string
406 "/name-details?name="
407 uname)
408 :target "_blank"
409 hname))
410 (:td :align "right" points)
411 (:td (:form :action "/names" :method "post"
412 (:/input :type "hidden" :name "action"
413 :value "vote")
414 (:/input :type "hidden" :name "name"
415 :value hname)
416 (:select :name "vote"
417 (:option :value "positive"
418 "Positive")
419 (:option :value "negative"
420 "Negative"))
421 (:/input :type "text"
422 :name "reason"
423 :value "Reason"
424 :maxlength "64"
425 :size "32")
426 (:/input :type "submit"
427 :value "Vote")))))))))))
428
429 (defun ne-details (req connection)
430 (let* ((stream (connection-stream connection))
431 (name (req-var req :get :name))
432 (details (name-entry-details name))
433 (title (format nil "Details for \"~A\"" (html-escape name))))
434 (unless (and name details)
435 (http-redirect stream req "/names"))
436 (http-reply-send
437 stream
438 (do-html nil
439 (:html (:head (:/link :rel "stylesheet"
440 :href "/css/chat.css"
441 :type "text/css")
442 (:title title))
443 (:body
444 (:a :href "/names" "&lt;- Back")
445 (:h1 title)
446 (:h2 "Positive votes")
447 (:table :cellspacing "10"
448 (:tr (:th "IP Address") (:th :align "left" "Reason"))
449 (do-html-loop (for (address reason) in (first details)
450 for hreason = (html-escape reason))
451 (:tr (:td :align "center" address) (:td hreason))))
452 (:/br)
453 (:h2 "Negative votes")
454 (:table :cellspacing "10"
455 (:tr (:th "IP Address") (:th :align "left" "Reason"))
456 (do-html-loop (for (address reason) in (second details)
457 for hreason = (html-escape reason))
458 (:tr (:td :align "center" address) (:td reason))))))))))