crow-httpd: switch from CVS RCSID to GIT revision for versioning
[mmondor.git] / mmsoftware / cl / server / crow-test-applications.lisp
CommitLineData
61ba5972 1;;;; $Id: crow-test-applications.lisp,v 1.8 2013/09/03 04:52:37 mmondor Exp $
e195b470
MM
2
3#|
4
5Copyright (c) 2012, Matthew Mondor
6All rights reserved.
7
8Redistribution and use in source and binary forms, with or without
9modification, are permitted provided that the following conditions
10are met:
111. Redistributions of source code must retain the above copyright
12 notice, this list of conditions and the following disclaimer.
132. 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
17THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR
18IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
19OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
20IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT,
21INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
22BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
23USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
24THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
26THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27
28|#
29
bdac54ef 30(declaim (optimize (speed 3) (safety 1) (debug 3)))
e195b470 31
0fb813ed
MM
32;;; To allow COMPILE-FILE easiy
33(eval-when (:compile-toplevel)
34 (pushnew :crow-application *features*) ; XXX Currently needed
35 (load "httpd"))
36
bdac54ef
MM
37(defpackage :test-applications
38 (:use :cl :server :httpd :html)
39 (:export #:chat-frames
40 #:chat-lines
41 #:chat-prompt
42 #:ne-names
6d916a43
MM
43 #:ne-details
44 #:paste-new
45 #:paste-view))
e195b470 46
bdac54ef 47(in-package :test-applications)
e195b470 48
bdac54ef
MM
49
50
51;;; Helper functions
f1f7c601
MM
52
53(defmacro with-temp-file ((path filename) &body body)
54 (let ((tmpfile (gensym)))
55 `(let* ((,tmpfile (ext:mkstemp ,filename))
56 (,path ,tmpfile))
57 (unwind-protect
58 (progn
59 ,@body)
60 (handler-case
61 (delete-file ,tmpfile)
62 (simple-error ()
63 nil))))))
64
65;;; XXX Perhaps rename original to .old then move tmpfile to original name.
66;;; Also, perhaps provide a thread designed to regularily save data, for
67;;; use by such applications... of course, in the long term a DB should
68;;; be used.
69(defun save-list (filename list)
70 (with-temp-file (tmpfile filename)
71 (with-open-file (s tmpfile :direction :output)
72 (write list :stream s)
73 (format s "~%")
74 (finish-output s))
75 (rename-file tmpfile filename :if-exists :supersede)))
76
77(defun load-list (filename)
78 (handler-case
79 (with-open-file (s filename :direction :input)
80 (read s))
81 (file-error ()
82 '())))
83
84
e195b470
MM
85;;; Test "chat" board with 1024 messages backlog
86
307941fb
MM
87(defparameter *chat-lines-file*
88 (concatenate 'string httpd::*data-dir* "/chat-lines.lisp"))
e195b470
MM
89(defparameter *chat-lines-save-interval* 300)
90
91(defvar *chat-lines-save-lock* (mp:make-lock :name 'chat-lines-save-lock))
92(defvar *chat-lines*
93 (let ((lines (load-list *chat-lines-file*)))
94 (server::make-fifo :head lines
95 :tail (last lines)
96 :count (length lines)
97 :size 1024)))
98(defvar *chat-lines-modified* nil)
99
100(defun chat-save-regularily ()
101 (loop
102 do
103 (handler-case
104 (progn
105 (sleep *chat-lines-save-interval*)
106 (mp:with-lock (*chat-lines-save-lock*)
107 (when *chat-lines-modified*
108 (save-list *chat-lines-file*
109 (server::fifo-head *chat-lines*))
110 (setf *chat-lines-modified* nil))))
111 (t (e)
112 (log-line "# ~A ~A" (type-of e) e)))))
113
114(defvar *chat-lines-save-thread*
115 (mp:process-run-function 'chat-lines-save-thread #'chat-save-regularily))
116
117(defun chat-frames (req connection)
118 (declare (ignore req))
9856c64a 119 (reply-send
e195b470
MM
120 (connection-stream connection)
121 (do-html nil
1c1ac14c 122 (:html :style "height: 99%"
e195b470
MM
123 (:head
124 (:/link :rel "stylesheet"
1f29d500 125 :href "/css/crow-httpd.css"
e195b470 126 :type "text/css")
3187dd24
MM
127 (:/link :rel "shortcut icon"
128 :href "/images/crow-httpd-icon.png"
129 :type "image/png")
e195b470
MM
130 (:title "Share your comments"))
131 (:body :style "height: 99%"
132 (:table :width "100%" :style "height: 99%"
133 (:tr
134 (:td :width "100%" :height "2%"
135 :align "center" :valign "middle"
136 (:h2 "Share your comments")))
137 (:tr
138 (:td :width "100%" :height "20%"
139 :valign "middle"
140 (:iframe :name "prompt" :src "/chat-prompt"
141 :frameborder "0"
142 :scrolling "no"
143 :width "100%"
144 :height "100%"
145 "Prompt")))
146 (:tr
147 (:td :width "100%" :height "78%" :valign "top"
148 (:iframe :name "lines" :src "/chat-lines"
149 :frameborder "0"
150 :scrolling "auto"
151 :width "100%"
152 :height "100%"
153 "Lines")))))))))
154
155(defun chat-lines (req connection)
156 (declare (ignore req))
9856c64a
MM
157 (let ((reply (make-reply)))
158 (reply-header-set-nocache reply)
159 (reply-content-add
e195b470
MM
160 reply
161 (do-html nil
162 (:html (:head
163 (:/link :rel "stylesheet"
1f29d500 164 :href "/css/crow-httpd.css"
e195b470
MM
165 :type "text/css")
166 (:/meta :http-equiv "refresh" :content "15")
167 (:title "Messages"))
168 (:body
169 (do-html-loop (with lines = (reverse (server::fifo-head
170 *chat-lines*))
171 for m in lines
172 for (from when msg) = m)
173 (:table :width "100%"
174 (:tr (:td :width "100%" :align "left"
175 (:b
176 "From: " from
177 ", At: " (server-time-rfc when)
178 " (" (server-time-interval
179 (- (server-time) when)) " ago)")))
180 (:tr (:td :width "100%" :align "left"
181 (:pre
182 (html-escape msg))))))))))
9856c64a 183 (reply-flush reply (connection-stream connection))))
e195b470
MM
184
185(defun chat-prompt (req connection)
0fb813ed
MM
186 (declare (ignore req))
187 (with-http-let
188 ((msg :post :message))
e195b470
MM
189 (when msg
190 (server::fifo-append
191 *chat-lines*
192 (list (connection-address-string connection)
193 (server-time)
194 msg))
195 (mp:with-lock (*chat-lines-save-lock*)
196 (setf *chat-lines-modified* t))))
9856c64a 197 (reply-send
e195b470
MM
198 (connection-stream connection)
199 (do-html nil
200 (:html (:head
201 (:/link :rel "stylesheet"
6d916a43
MM
202 :href "/css/crow-httpd.css"
203 :type "text/css")
e195b470
MM
204 (:title "Prompt"))
205 (:body :style "height: 99%"
206 (:table :width "100%" :style "height: 93%"
207 (:tr
208 (:td :width "100%" :align "center"
209 (:form :action "/chat-prompt" :method "post"
210 (:textarea :name "message"
211 :rows 5
212 :cols 79
213 "")
214 (:/br)
215 (:/input :type "submit"
216 :value "Post"))))))))))
217
218
219;;; Temporary name suggestion+voting application
220
221(defstruct name-entry
222 (positive (make-hash-table :test #'equal))
223 (negative (make-hash-table :test #'equal)))
224
307941fb
MM
225(defparameter *name-entries-file*
226 (concatenate 'string httpd::*data-dir* "/name-entries.lisp"))
e195b470
MM
227(defparameter *name-entries-save-interval* 300)
228
229(defvar *name-entries-lock* (mp:make-lock :name 'name-entries-lock
230 :recursive t))
231(defvar *name-entries* (make-hash-table :test #'equalp))
232
233(defun list<-name-entries ()
234 (mp:with-lock (*name-entries-lock*)
235 (loop
236 for key being each hash-key of *name-entries* using (hash-value val)
237 collect
238 `(,key
239 ,(loop
240 for a being each hash-key of (name-entry-positive val)
241 using (hash-value r)
242 collect `(,a ,r))
243 ,(loop
244 for a being each hash-key of (name-entry-negative val)
245 using (hash-value r)
246 collect `(,a ,r))))))
247
248(defun name-entries<-list (list)
249 (mp:with-lock (*name-entries-lock*)
250 (loop
251 for l in list
252 for (name positive negative) = l
253 do
254 (let ((ne (make-name-entry)))
255 (mapc #'(lambda (i)
256 (destructuring-bind (address reason) i
257 (setf (gethash address (name-entry-positive ne))
258 reason)))
259 positive)
260 (mapc #'(lambda (i)
261 (destructuring-bind (address reason) i
262 (setf (gethash address (name-entry-negative ne))
263 reason)))
264 negative)
265 (setf (gethash name *name-entries*) ne))))
266 t)
267
268(defvar *name-entries-modified*
269 (prog1
270 nil
271 (name-entries<-list (load-list *name-entries-file*))))
272
273(defun name-entries-save-regularily ()
274 (loop
275 do
276 (handler-case
277 (progn
278 (sleep *name-entries-save-interval*)
279 (mp:with-lock (*name-entries-lock*)
280 (when *name-entries-modified*
281 (save-list *name-entries-file* (list<-name-entries))
282 (setf *name-entries-modified* nil))))
283 (t (e)
284 (log-line "# ~A ~A" (type-of e) e)))))
285
286(defvar *name-entries-save-thread*
287 (mp:process-run-function 'name-entries-save-regularily
288 #'name-entries-save-regularily))
289
290(defun name-entries-popularity ()
291 (mp:with-lock (*name-entries-lock*)
292 (sort
293 (sort
294 (loop
295 with name-entries = *name-entries*
296 for key being each hash-key of name-entries
297 using (hash-value val)
298 collect `(,key ,(- (hash-table-count (name-entry-positive val))
299 (hash-table-count (name-entry-negative val)))))
300 #'string-lessp :key #'first)
301 #'> :key #'second)))
302
303(defun name-entry-details (name)
304 (mp:with-lock (*name-entries-lock*)
305 (let ((ne (gethash name *name-entries*)))
306 (unless ne
307 (return-from name-entry-details nil))
308 `(,(loop
309 for a being each hash-key of (name-entry-positive ne)
310 using (hash-value r)
311 collect `(,a ,r))
312 ,(loop
313 for a being each hash-key of (name-entry-negative ne)
314 using (hash-value r)
315 collect `(,a ,r))))))
316
317(defun name-entry-add (name address reason)
318 (mp:with-lock (*name-entries-lock*)
319 (let ((name-entries *name-entries*))
320 (when (gethash name name-entries)
321 (return-from name-entry-add nil))
322 (let ((ne (make-name-entry)))
323 (setf (gethash name name-entries) ne
324 (gethash address (name-entry-positive ne)) reason
325 *name-entries-modified* t)
326 t))))
327
328(defun name-entry-vote (name address reason vote)
329 (mp:with-lock (*name-entries-lock*)
330 (let ((ne (gethash name *name-entries*)))
331 (unless ne
332 (return-from name-entry-vote nil))
333 (setf (gethash address (if (eq :positive vote)
334 (name-entry-positive ne)
335 (name-entry-negative ne))) reason
336 *name-entries-modified* t)
337 t)))
338
339(defun ne-names (req connection)
0fb813ed 340 (declare (ignore req))
e195b470 341 ;; First handle any add/vote
0fb813ed
MM
342 (with-http-let
343 ((action :post :action)
344 (name :post :name)
345 (reason :post :reason)
346 (vote :post :vote))
e195b470
MM
347 (cond ((and (string= action "add")
348 (> (length name) 0)
349 (> (length reason) 0))
350 (name-entry-add name
351 (connection-address-string connection)
352 reason))
353 ((and (string= action "vote")
354 (> (length name) 0)
355 (> (length reason) 0)
356 (member vote '("positive" "negative") :test #'string=))
357 (name-entry-vote name
358 (connection-address-string connection)
359 reason
360 (if (string= "positive" vote)
361 :positive :negative)))))
9856c64a 362 (reply-send
e195b470
MM
363 (connection-stream connection)
364 (do-html nil
365 (:html (:head
366 (:/link :rel "stylesheet"
1f29d500 367 :href "/css/crow-httpd.css"
e195b470 368 :type "text/css")
3187dd24
MM
369 (:/link :rel "shortcut icon"
370 :href "/images/crow-httpd-icon.png"
371 :type "image/png")
e195b470
MM
372 (:title "Suggest a name for this HTTPd"))
373 (:body
374 (:h1 "Suggest a name for this HTTPd")
4949c868 375 (:a :href "http://git.pulsar-zone.net/?p=mmondor.git;a=tree;f=mmsoftware/cl/server;hb=HEAD"
e195b470
MM
376 :target "_blank"
377 "(source code of the server)")
378 (:/br)(:/br)
0497ea97
MM
379 (:h1 "Important notice")
380 (:p (:b "The name of this HTTP/web server has been chosen. "
381 "The one that was retained is \"Crow\". ")
382 "Crow is of course the name of a smart bird, but also "
383 "that of a Native American nation. As such, the name "
384 "remains in theme with some other web server names "
385 "such as Apache. Moreover, a logo should be rather "
386 "easy to devise from either the silhouette of a crow "
387 "bird or of one of its feathers.")
388 (:p "Thanks to everyone who participated!")
389 (:p "As this is one of the few existing applications "
390 "running under Crow, it will keep running for a while, "
391 "still.")
e195b470
MM
392 (:h1 "Suggest another name")
393 (:form :action "/names" :method "post"
394 (:/input :type "hidden" :name "action" :value "add")
395 (:table
396 (:tr
397 (:td :align "right" "Name")
398 (:td (:/input :type "text"
399 :name "name"
400 :value ""
401 :maxlength "32"
402 :size "32"))
403 (:td :align "right" "Reason")
404 (:td (:/input :type "text"
405 :name "reason"
406 :value ""
407 :maxlength "64"
408 :size "32"))
409 (:td (:/input :type "submit"
410 :value "Submit")))))
411 (:h1 "Current suggestions by popularity")
412 (:p "Click on a name to view more details.")
413 (:table :cellspacing "10"
414 (:tr
415 (:th :align "left" "Name") (:th "Points") (:th "Vote"))
416 (do-html-loop (for (name points) in (name-entries-popularity)
e195b470
MM
417 for hname = (html-escape name))
418 (:tr
61ba5972 419 (:td (:a :href (make-url '("name-details") `(:name ,name))
e195b470
MM
420 :target "_blank"
421 hname))
422 (:td :align "right" points)
423 (:td (:form :action "/names" :method "post"
424 (:/input :type "hidden" :name "action"
425 :value "vote")
426 (:/input :type "hidden" :name "name"
427 :value hname)
428 (:select :name "vote"
429 (:option :value "positive"
430 "Positive")
431 (:option :value "negative"
432 "Negative"))
433 (:/input :type "text"
434 :name "reason"
435 :value "Reason"
436 :maxlength "64"
437 :size "32")
438 (:/input :type "submit"
439 :value "Vote")))))))))))
440
441(defun ne-details (req connection)
442 (let* ((stream (connection-stream connection))
443 (name (req-var req :get :name))
444 (details (name-entry-details name))
445 (title (format nil "Details for \"~A\"" (html-escape name))))
446 (unless (and name details)
447 (http-redirect stream req "/names"))
9856c64a 448 (reply-send
e195b470
MM
449 stream
450 (do-html nil
451 (:html (:head (:/link :rel "stylesheet"
1f29d500 452 :href "/css/crow-httpd.css"
e195b470 453 :type "text/css")
3187dd24
MM
454 (:/link :rel "shortcut icon"
455 :href "/images/crow-httpd-icon.png"
456 :type "image/png")
e195b470
MM
457 (:title title))
458 (:body
459 (:a :href "/names" "&lt;- Back")
460 (:h1 title)
461 (:h2 "Positive votes")
462 (:table :cellspacing "10"
463 (:tr (:th "IP Address") (:th :align "left" "Reason"))
464 (do-html-loop (for (address reason) in (first details)
465 for hreason = (html-escape reason))
466 (:tr (:td :align "center" address) (:td hreason))))
467 (:/br)
468 (:h2 "Negative votes")
469 (:table :cellspacing "10"
470 (:tr (:th "IP Address") (:th :align "left" "Reason"))
471 (do-html-loop (for (address reason) in (second details)
472 for hreason = (html-escape reason))
473 (:tr (:td :align "center" address) (:td reason))))))))))
6d916a43
MM
474
475
476;;; Minimal pastebin application
477
478(defparameter *paste-file*
479 (concatenate 'string httpd::*data-dir* "/paste-entries.lisp"))
480(defparameter *paste-save-interval* 300)
013f5df3 481(defparameter *paste-expire-days* '(30 14 7 1))
90e30491
MM
482(defparameter *paste-random-max* #xFFFF)
483(defparameter *paste-random-tries* 32)
6d916a43
MM
484
485(defvar *paste-lock* (mp:make-lock :name '#:paste-lock
486 :recursive t))
487(defvar *paste-entries* (make-hash-table :test #'eq))
488
489(defun list<-paste-entries ()
490 (mp:with-lock (*paste-lock*)
491 (loop
492 with entries = *paste-entries*
493 with time = (server-time)
6d916a43 494 for key being each hash-key of entries using (hash-value val)
013f5df3 495 when (> (getf val :expiration) time) collect `(:id ,key ,@val)
6d916a43
MM
496 else do (remhash key entries))))
497
498(defun paste-entries<-list (list)
499 (mp:with-lock (*paste-lock*)
500 (loop
501 for l in list
502 do
013f5df3 503 (destructuring-bind (&key id from when expiration text) l
6d916a43 504 (setf (gethash id *paste-entries*)
013f5df3
MM
505 `(:from ,from :when ,when :expiration ,expiration
506 :text ,text)))))
6d916a43
MM
507 t)
508
509(defvar *paste-modified*
510 (prog1
511 nil
512 (paste-entries<-list (load-list *paste-file*))))
513
514(defun paste-save-regularily ()
515 (loop
516 do
517 (handler-case
518 (progn
519 (sleep *paste-save-interval*)
520 (mp:with-lock (*paste-lock*)
521 (when *paste-modified*
522 (save-list *paste-file* (list<-paste-entries))
523 (setf *paste-modified* nil))))
524 (t (e)
525 (log-line "# ~A ~A" (type-of e) e)))))
526
527(defvar *paste-save-thread*
528 (mp:process-run-function '#:paste-save-regularily #'paste-save-regularily))
529
90e30491
MM
530(defun paste-random ()
531 (loop
532 with tries = *paste-random-tries*
533 repeat tries
534 for r = (random *paste-random-max*)
535 unless (gethash r *paste-entries*) return r
536 finally (error "Could not allocate paste-id")))
537
6d916a43
MM
538(defun paste-new (req connection)
539 (declare (ignore req))
540 (let ((id nil)
61ba5972
MM
541 (site nil)
542 (url nil))
6d916a43
MM
543 (with-http-let
544 ((host :header :host)
013f5df3
MM
545 (text :post :text)
546 (days :post :days))
6d916a43
MM
547 (when (and text (> (length text) 0))
548 (setf site host
549 id
61ba5972
MM
550 (let* ((id (paste-random))
551 (paste-expire-days *paste-expire-days*)
552 (days-min (apply #'min paste-expire-days))
553 (days-max (apply #'max paste-expire-days))
554 (current-time (server-time))
555 (expiration (let ((days (handler-case
556 (parse-integer days)
557 (t (e)
558 days-max))))
559 (if (>= days-max days days-min)
560 days
561 days-max))))
562 (mp:with-lock (*paste-lock*)
563 (setf (gethash id *paste-entries*)
564 (list :from (connection-address-string connection)
565 :when current-time
566 :expiration (+ current-time
567 (* expiration 86400))
568 :text text)
569 *paste-modified* t))
570 id)
571 url (make-url '("paste") `(:p ,(format nil "~36R" id))))))
6d916a43
MM
572 (reply-send
573 (connection-stream connection)
574 (do-html nil
575 (:html (:head
576 (:/link :rel "stylesheet"
577 :href "/css/crow-httpd.css"
578 :type "text/css")
8e1afe03
MM
579 (:/link :rel "shortcut icon"
580 :href "/images/crow-httpd-icon.png"
581 :type "image/png")
6d916a43
MM
582 (:title "New paste"))
583 (:body
584 (do-html-when id
585 (:h2 "Your paste")
61ba5972
MM
586 (:a :href url
587 (format nil "http://~A~A" site url))
6d916a43
MM
588 (:/hr))
589 (:h2 "New paste")
590 (:form :action "/paste-new" :method "post"
013f5df3
MM
591 "Expire in "
592 (:select :name "days"
593 (do-html-loop (for day in *paste-expire-days*)
594 (:option :value day day)))
595 " day(s)"
596 (:/br)
6d916a43
MM
597 (:textarea :name "text"
598 :rows 25
599 :cols 79
600 "")
601 (:/br)
602 (:/input :type "submit" :value "Post"))))))))
603
604(defun paste-view (req connection)
605 (declare (ignore req))
606 (with-http-let
eeb81fd9
MM
607 ((id :get :p)
608 (raw :get :raw))
6d916a43
MM
609 (let ((entry
610 (let ((i (handler-case
90e30491 611 (parse-integer id :radix 36)
6d916a43
MM
612 (t (e)
613 -1))))
614 (if (and (typep i 'fixnum) (> i -1))
615 (mp:with-lock (*paste-lock*)
616 (gethash i *paste-entries*))
617 nil))))
eeb81fd9
MM
618 (if (or (not raw) (not entry))
619 (reply-send
620 (connection-stream connection)
621 (do-html nil
622 (:html (:head
623 (:/link :rel "stylesheet"
624 :href "/css/crow-httpd.css"
625 :type "text/css")
626 (:/link :rel "shortcut icon"
627 :href "/images/crow-httpd-icon.png"
628 :type "image/png")
629 (do-html-if entry
630 (:title (format nil "Paste #~36R" id))
631 (:title "Unknown paste entry")))
632 (do-html-if entry
633 (:body
634 (:h1 (format nil "Paste #~36R" id))
61ba5972
MM
635 (:a :href (make-url '("paste-new")) "New Paste") " | "
636 (:a :href (make-url '("paste") `(:p ,id :raw 1))
eeb81fd9
MM
637 "View raw")
638 (:/hr)
639 (:p
640 (let ((current-time (server-time))
641 (time (getf entry :when))
642 (expiration (getf entry :expiration)))
643 (format nil "Posted on ~A (~A ago), expires in ~A"
644 (server-time-rfc time)
645 (server-time-interval (- current-time time))
646 (server-time-interval (- expiration
647 current-time)))))
648 (:/hr)
649 (:pre (html-escape (getf entry :text))))
650 (:body
651 (:h1 "Unknown paste entry")
652 (:a :href "/paste-new" "New Paste"))))))
653 (reply-flush
654 (make-reply :content (list (getf entry :text))
655 :mime-type "text/plain")
656 (connection-stream connection))))))