add first draft of a survey module

vii · Feb 25, 2010 · 4dd4fde · 4dd4fde
1 parent a434f9b
commit 4dd4fde
Show file tree

Hide file tree

Showing 3 changed files with 77 additions and 0 deletions.
diff --git a/src/packages.lisp b/src/packages.lisp
@@ -317,6 +317,7 @@
    #:frame-username
    #:frame-messages
    #:frame-trace-info
+   #:frame-exit-hooks
    #:list-all-frames
    #:find-frame
    #:frame-id
@@ -331,6 +332,7 @@
    #:channel
    #:channel-notify
    #:channel-update
+   #:channel-destroy
    #:find-channel
 
    #:webapp-respond-ajax-body
@@ -423,6 +425,10 @@
   (:nicknames #:tpd2.blog)
   (:use #:cl #:tpd2.webapp #:tpd2.ml #:tpd2.ml.html #:tpd2.lib #:tpd2.datastore))
 
+(defpackage #:teepeedee2.survey
+  (:nicknames #:tpd2.survey)
+  (:use #:cl #:tpd2.webapp #:tpd2.ml #:tpd2.ml.html #:tpd2.lib #:tpd2.datastore))
+
 (defpackage #:teepeedee2.game.truc
   (:nicknames #:tpd2.game.truc)
   (:use #:tpd2.game #:tpd2.ml #:tpd2.lib #:teepeedee2.webapp #:common-lisp #:tpd2.ml.html))

diff --git a/src/survey/survey.lisp b/src/survey/survey.lisp
@@ -0,0 +1,68 @@
+(in-package #:tpd2.survey)
+
+(defstruct (question (:type list))
+  text
+  choices)
+
+(defrecord survey
+  (name :index t)
+  text
+  questions)
+
+(defmyclass (survey-channel (:include simple-channel))
+    survey)
+
+(defrecord response
+  (survey-name :index t)
+  responses
+  (time :initform (get-universal-time))
+  (trace-details :initform (tpd2.http:servestate-origin*)))
+
+(my-defun response 'object-to-ml ()
+  (<tr :class "survey-response"
+       (loop for r in (my responses)
+	     do (<td r))))
+
+(my-defun survey-channel responses ()
+  (datastore-retrieve-indexed 'response 'survey-name (survey-name (my survey))))
+
+(my-defun survey-channel questions ()
+  (survey-questions (my survey)))
+
+(my-defun survey-channel 'simple-channel-body-ml ()
+  (<table :class "survey-channel"
+	  (<thead
+	    (loop for q in (my questions) do (<th (question-text q))))
+	  (loop for c in (my responses) repeat 50 do
+		(output-object-to-ml c))))
+
+(my-defun survey channel-name ()
+  (byte-vector-cat "survey:" (my name)))
+(my-defun survey gen-page-lambda (path)
+  (unless (find-channel (my channel-name))
+    (make-survey-channel :survey me :id (my channel-name)))
+
+  (let ((qvars (loop for i from 0 for q in (my questions) collect (intern (strcat 'q i)))))
+    `(with-compile-time-site () 
+       (defpage-lambda ,path
+	   (lambda (,@qvars .javascript.)
+	     (cond ((or ,@qvars)
+		    (let ((chan (find-channel ,(my channel-name))))
+		      (make-response :survey-name ,(my name)
+				     :responses (list ,@qvars))
+		      (channel-notify chan)
+		      (cond (.javascript. (webapp-respond-ajax-body))
+			    (t
+			     (webapp "Thank you for responding"
+			       (output-object-to-ml chan))))))
+		   (t
+		    (webapp ,(my name)
+		      (<div :class "survey"
+			    (html-action-form ("" :action-link ,path :async nil)
+				,(loop for q in (my questions)
+				       for v in qvars
+				       collect `(,v nil :label ,(question-text q) :type :select-one :options ,(question-choices q)))))))))
+	 :create-frame nil))))
+
+(my-defun survey register (path)
+  (eval (my gen-page-lambda path)))
diff --git a/teepeedee2.asd b/teepeedee2.asd
@@ -115,6 +115,9 @@
 					      :components ((:file "entry")
 							   (:file "feed" :depends-on ("blog"))
 							   (:file "blog" :depends-on ("entry"))))
+				     (:module :survey
+					      :depends-on (:webapp :ml :datastore)
+					      :components ((:file "survey")))
 				     (:module :truc
 					      :depends-on (:game)
 					      :components ( (:file "truc") (:file "web" :depends-on ("truc"))