1 ;;;; $Id: test-applications.lisp,v 1.6 2012/09/14 21:38:55 mmondor Exp $
5 Copyright
(c) 2012, Matthew Mondor
8 Redistribution and use in source and binary forms
, with or without
9 modification
, are permitted provided that the following conditions
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.
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.
30 (declaim (optimize (speed 3) (safety 1) (debug 3)))
32 (defpackage :test-applications
33 (:use
:cl
:server
:httpd
:html
)
34 (:export
#:chat-frames
40 (in-package :test-applications
)
43 "$Id: test-applications.lisp,v 1.6 2012/09/14 21:38:55 mmondor Exp $")
48 (defmacro with-temp-file
((path filename
) &body body
)
49 (let ((tmpfile (gensym)))
50 `(let* ((,tmpfile
(ext:mkstemp
,filename
))
56 (delete-file ,tmpfile
)
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
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
)
70 (rename-file tmpfile filename
:if-exists
:supersede
)))
72 (defun load-list
(filename)
74 (with-open-file (s filename
:direction
:input
)
80 ;;; Test "chat" board with 1024 messages backlog
82 (defparameter *chat-lines-file
* "/home/mmondor/tmp/chat-lines.lisp")
83 (defparameter *chat-lines-save-interval
* 300)
85 (defvar *chat-lines-save-lock
* (mp:make-lock
:name
'chat-lines-save-lock
))
87 (let ((lines (load-list *chat-lines-file
*)))
88 (server::make-fifo
:head lines
92 (defvar *chat-lines-modified
* nil
)
94 (defun chat-save-regularily
()
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
))))
106 (log-line "# ~A ~A" (type-of e
) e
)))))
108 (defvar *chat-lines-save-thread
*
109 (mp:process-run-function
'chat-lines-save-thread
#'chat-save-regularily
))
111 (defun chat-frames
(req connection
)
112 (declare (ignore req
))
114 (connection-stream connection
)
118 (:/link
:rel
"stylesheet"
119 :href
"/css/chat.css"
121 (:title
"Share your comments"))
122 (:body
:style
"height: 99%"
123 (:table
:width
"100%" :style
"height: 99%"
125 (:td
:width
"100%" :height
"2%"
126 :align
"center" :valign
"middle"
127 (:h2
"Share your comments")))
129 (:td
:width
"100%" :height
"20%"
131 (:iframe
:name
"prompt" :src
"/chat-prompt"
138 (:td
:width
"100%" :height
"78%" :valign
"top"
139 (:iframe
:name
"lines" :src
"/chat-lines"
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
154 (:/link
:rel
"stylesheet"
155 :href
"/css/chat.css"
157 (:/meta
:http-equiv
"refresh" :content
"15")
160 (do-html-loop (with lines
= (reverse (server::fifo-head
163 for
(from when msg
) = m
)
164 (:table
:width
"100%"
165 (:tr
(:td
:width
"100%" :align
"left"
168 ", At: " (server-time-rfc when
)
169 " (" (server-time-interval
170 (- (server-time) when
)) " ago)")))
171 (:tr
(:td
:width
"100%" :align
"left"
173 (html-escape msg
))))))))))
174 (http-reply-flush reply
(connection-stream connection
))))
176 (defun chat-prompt
(req connection
)
178 ((msg :post
:message
))
182 (list (connection-address-string connection
)
185 (mp:with-lock
(*chat-lines-save-lock
*)
186 (setf *chat-lines-modified
* t
))))
188 (connection-stream connection
)
191 (:/link
:rel
"stylesheet"
192 :href
"/css/chat.css"
195 (:body
:style
"height: 99%"
196 (:table
:width
"100%" :style
"height: 93%"
198 (:td
:width
"100%" :align
"center"
199 (:form
:action
"/chat-prompt" :method
"post"
200 (:textarea
:name
"message"
205 (:/input
:type
"submit"
206 :value
"Post"))))))))))
209 ;;; Temporary name suggestion+voting application
211 (defstruct name-entry
212 (positive (make-hash-table :test
#'equal
))
213 (negative (make-hash-table :test
#'equal
)))
215 (defparameter *name-entries-file
* "/home/mmondor/tmp/name-entries.lisp")
216 (defparameter *name-entries-save-interval
* 300)
218 (defvar *name-entries-lock
* (mp:make-lock
:name
'name-entries-lock
220 (defvar *name-entries
* (make-hash-table :test
#'equalp
))
222 (defun list
<-name-entries
()
223 (mp:with-lock
(*name-entries-lock
*)
225 for key being each hash-key of
*name-entries
* using
(hash-value val
)
229 for a being each hash-key of
(name-entry-positive val
)
233 for a being each hash-key of
(name-entry-negative val
)
235 collect
`(,a
,r
))))))
237 (defun name-entries
<-list
(list)
238 (mp:with-lock
(*name-entries-lock
*)
241 for
(name positive negative
) = l
243 (let ((ne (make-name-entry)))
245 (destructuring-bind (address reason
) i
246 (setf (gethash address
(name-entry-positive ne
))
250 (destructuring-bind (address reason
) i
251 (setf (gethash address
(name-entry-negative ne
))
254 (setf (gethash name
*name-entries
*) ne
))))
257 (defvar *name-entries-modified
*
260 (name-entries<-list
(load-list *name-entries-file
*))))
262 (defun name-entries-save-regularily
()
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
))))
273 (log-line "# ~A ~A" (type-of e
) e
)))))
275 (defvar *name-entries-save-thread
*
276 (mp:process-run-function
'name-entries-save-regularily
277 #'name-entries-save-regularily
))
279 (defun name-entries-popularity
()
280 (mp:with-lock
(*name-entries-lock
*)
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
)
292 (defun name-entry-details
(name)
293 (mp:with-lock
(*name-entries-lock
*)
294 (let ((ne (gethash name
*name-entries
*)))
296 (return-from name-entry-details nil
))
298 for a being each hash-key of
(name-entry-positive ne
)
302 for a being each hash-key of
(name-entry-negative ne
)
304 collect
`(,a
,r
))))))
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
)
317 (defun name-entry-vote
(name address reason vote
)
318 (mp:with-lock
(*name-entries-lock
*)
319 (let ((ne (gethash name
*name-entries
*)))
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
)
328 (defun ne-names
(req connection
)
329 ;; First handle any add/vote
331 ((action :post
:action
)
333 (reason :post
:reason
)
335 (cond ((and (string= action
"add")
337 (> (length reason
) 0))
339 (connection-address-string connection
)
341 ((and (string= action
"vote")
343 (> (length reason
) 0)
344 (member vote
'("positive" "negative") :test
#'string
=))
345 (name-entry-vote name
346 (connection-address-string connection
)
348 (if (string= "positive" vote
)
349 :positive
:negative
)))))
351 (connection-stream connection
)
354 (:/link
:rel
"stylesheet"
355 :href
"/css/chat.css"
357 (:title
"Suggest a name for this HTTPd"))
359 (:h1
"Suggest a name for this HTTPd")
360 (:a
:href
"http://cvs.pulsar-zone.net/cgi-bin/cvsweb.cgi/mmondor/mmsoftware/cl/server/"
362 "(source code of the server)")
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, "
377 (:h1
"Suggest another name")
378 (:form
:action
"/names" :method
"post"
379 (:/input
:type
"hidden" :name
"action" :value
"add")
382 (:td
:align
"right" "Name")
383 (:td
(:/input
:type
"text"
388 (:td
:align
"right" "Reason")
389 (:td
(:/input
:type
"text"
394 (:td
(:/input
:type
"submit"
396 (:h1
"Current suggestions by popularity")
397 (:p
"Click on a name to view more details.")
398 (:table
:cellspacing
"10"
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
))
405 (:td
(:a
:href
(concatenate 'string
406 "/name-details?name="
410 (:td
:align
"right" points
)
411 (:td
(:form
:action
"/names" :method
"post"
412 (:/input
:type
"hidden" :name
"action"
414 (:/input
:type
"hidden" :name
"name"
416 (:select
:name
"vote"
417 (:option
:value
"positive"
419 (:option
:value
"negative"
421 (:/input
:type
"text"
426 (:/input
:type
"submit"
427 :value
"Vote")))))))))))
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"))
439 (:html
(:head
(:/link
:rel
"stylesheet"
440 :href
"/css/chat.css"
444 (:a
:href
"/names" "<- Back")
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
))))
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
))))))))))