marcuskammer/dev.metalisp.survey
1
0
Fork 0
Code Issues 9 Pull requests Projects Releases Packages Wiki Activity Actions

Show the results of questionnaires in the survey view

Browse source
This commit is contained in:
Marcus Kammer 2024-06-07 18:55:42 +02:00
parent d21ec8e4ee
commit 8becb3d8aa
5 changed files with 107 additions and 49 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
src/handlers/main.lisp
View file

@ -1,7 +1,9 @@
(in-package :ml-survey/handlers)
(defun surveys-data-dir ()
(ensure-directories-exist (uiop:merge-pathnames* "data/surveys")))
(let ((data-dir (uiop:merge-pathnames* "data/surveys/")))
(ensure-directories-exist data-dir)
data-dir))
(defun split-uri (uri)
(check-type uri string)

9
src/handlers/questionnaire-submit.lisp
View file

@ -2,11 +2,10 @@
(defun questionnaire-submit-uri-p (uri)
"Check if the request URI matches the pattern '/survey/<numeric>/submit'"
(let ((parts (split-uri uri))
(survey (make-survey uri)))
(let ((parts (split-uri uri)))
(and (= (length parts) 3)
(string= (first parts) "survey")
(funcall survey 'id)
(every #'digit-char-p (second parts))
(search "submit" (third parts)))))
(defun questionnaire-submit-uri (request)
@ -21,7 +20,7 @@
(define-easy-handler (questionnaire-submit :uri #'questionnaire-submit-uri) nil
(let ((post-params (post-parameters* *request*))
(questionnaire-id (generate-uuid))
(survey (make-survey (request-uri*))))
(store-response (ensure-data-file-exist (funcall survey 'id) questionnaire-id)
(s (make-instance 'survey :id (second (split-uri (request-uri*))))))
(store-response (ensure-data-file-exist (survey-id s) questionnaire-id)
post-params)
(ml-survey/views:questionnaire-submit)))

10
src/handlers/questionnaire.lisp
View file

@ -2,12 +2,10 @@
(defun questionnaire-uri-p (uri)
"Check if the request URI matches the pattern '/survey/<numeric>'"
(let ((parts (split-uri uri))
(survey (make-survey uri)))
(let ((parts (split-uri uri)))
(and (= (length parts) 3)
(string= (first parts) "survey")
(every #'digit-char-p (second parts))
(funcall survey 'id-p))))
(every #'digit-char-p (second parts)))))
(defun questionnaire-uri (request)
(questionnaire-uri-p (request-uri request)))
@ -20,6 +18,6 @@
(t (error "Unsupported language: ~A" lang))))
(define-easy-handler (questionnaire :uri #'questionnaire-uri) (lang)
(let ((survey (make-survey (request-uri*))))
(let ((s (make-instance 'survey :id (second (split-uri (request-uri*))))))
(setf *html-lang* lang)
(funcall (choose-sus-form lang) (funcall survey 'id))))
(funcall (choose-sus-form lang) (survey-id s))))

103
src/handlers/survey.lisp
View file

@ -1,27 +1,96 @@
(in-package :ml-survey/handlers)
(defun make-survey (uri)
(labels ((survey-fn (action)
(case action
(id (second (split-uri uri)))
(defun extract-numbers (results)
"Extract numbers from a questionnaire RESULTS list.
Returns a list of integers."
(check-type results list)
(mapcar (lambda (x)
(parse-integer (remove-if (complement #'digit-char-p)
(cdr x)))) results))
(id-p (let ((ids (mapcar #'car (load-response (make-surveys-db-file)))))
(if (member (parse-integer (survey-fn 'id)) ids) t nil)))
(defun sus-calc-score (results)
(check-type results list)
(let ((counter 0))
(mapcar (lambda (x)
(setq counter (1+ counter))
(if (evenp counter)
(- 5 x)
(1- x)))
results)))
(uri-p (let ((parts (split-uri uri)))
(defun sus-calc-score-per-row (results)
(check-type results list)
(* (apply #'+ (sus-calc-score results)) 2.5))
(defun sus-calc (files)
(check-type files list)
(loop for f in files
for resp = (load-response f)
collect
(sus-calc-score-per-row (extract-numbers resp))))
(defclass survey ()
((id :initarg :id :reader survey-id)
(data-dir :initarg :data-dir :reader survey-data-dir)
(properties :initarg :properties :reader survey-properties)))
(defmethod initialize-instance :after ((survey survey) &key)
(with-slots (id data-dir properties) survey
(setf data-dir (uiop:merge-pathnames*
(format nil "~a/" id)
(surveys-data-dir)))
(setf properties (first (rest (assoc (parse-integer id)
(load-response (make-surveys-db-file))))))))
(defgeneric survey-id-p (survey)
(:documentation "Check if the survey ID is present in the surveys database."))
(defgeneric survey-data-dir-files (survey)
(:documentation "Get the list of files in the survey's data directory."))
(defgeneric survey-data-dir-p (survey)
(:documentation "Check if the survey's data directory exists."))
(defmethod survey-id-p ((survey survey))
(let ((ids (mapcar #'car (load-response (make-surveys-db-file)))))
(if (member (parse-integer (survey-id survey)) ids) t nil)))
(defmethod survey-data-dir-files ((survey survey))
(uiop:directory-files (survey-data-dir survey)))
(defmethod survey-data-dir-p ((survey survey))
(uiop:directory-exists-p (survey-data-dir survey)))
(defmethod survey-html ((survey survey))
(spinneret:with-html
(:table :class "table"
(:thead :class "thead-dark"
(:tr (:th :scope "col"
"Key")
(:th :scope "col"
"Value")))
(:tbody (loop for property in (survey-properties survey)
for key = (car property)
for value = (cdr property) do
(:tr (:td key)
(:td (if (string= key "questionnaire")
(:a :href (concatenate 'string "/survey/" (survey-id survey) value)
value)
value))))))))
(defun survey-uri-p (uri)
(let* ((parts (split-uri uri))
(s (make-instance 'survey :id (second parts))))
(and (= (length parts) 2)
(string= (first parts) "survey")
(every #'digit-char-p (second parts))
(survey-fn 'id-p))))
(properties (first (rest (assoc (parse-integer (survey-fn 'id))
(load-response (make-surveys-db-file)))))))))
#'survey-fn))
(every #'digit-char-p (survey-id s))
(survey-id-p s))))
(defun survey-uri (request)
(let ((survey (make-survey (request-uri request))))
(funcall survey 'uri-p)))
(survey-uri-p (request-uri request)))
(define-easy-handler (survey :uri #'survey-uri) ()
(let ((survey (make-survey (request-uri*))))
(ml-survey/views:survey (funcall survey 'id) (funcall survey 'properties))))
(let ((s (make-instance 'survey :id (second (split-uri (request-uri*))))))
(ml-survey/views:survey s
(when (survey-data-dir-p s)
(sus-calc (survey-data-dir-files s))))))

28
src/views/survey.lisp
View file

@ -1,24 +1,14 @@
(in-package :ml-survey/views)
(defun survey (id properties)
(defun survey (survey &optional results)
"Generates the view to show the survey created."
(check-type id string)
(check-type properties list)
(with-page (:title "Surveys")
(with-page (:title "Survey Details")
(navbar-en)
(:section :class "container"
(:h2 id)
(:table :class "table"
(:thead :class "thead-dark"
(:tr (:th :scope "col"
"Key")
(:th :scope "col"
"Value")))
(:tbody (loop for property in properties
for key = (car property)
for value = (cdr property) do
(:tr (:td key)
(:td (if (string= key "questionnaire")
(:a :href (concatenate 'string "/survey/" id value)
value)
value)))))))))
(:h2 (format nil "Survey ID: ~a" (ml-survey/handlers::survey-id survey)))
(:h3 "Properties")
(ml-survey/handlers::survey-html survey)
(:h3 "Questionnaire Results")
(:ul
(loop for result in results do
(:li result))))))