177 lines
6.5 KiB
Common Lisp
177 lines
6.5 KiB
Common Lisp
;;;; -*- mode: common-lisp; coding: utf-8; -*-
|
|
|
|
(defpackage ml-survey/survey
|
|
(:use #:cl)
|
|
(:import-from #:hunchentoot
|
|
#:define-easy-handler)
|
|
(:import-from #:ml-sbt/section
|
|
#:with-section
|
|
#:with-title-bar)
|
|
(:import-from #:ml-sbt/navbar
|
|
#:with-navbar)
|
|
(:import-from #:ml-sbt
|
|
#:*use-cdn*
|
|
#:with-page
|
|
#:body-header
|
|
#:body-main)
|
|
(:import-from #:ml-survey/assessment
|
|
#:assessment-render-results
|
|
#:parse-assessment)
|
|
(:export #:survey-id
|
|
#:survey
|
|
#:survey-properties-title
|
|
#:survey-properties-description))
|
|
|
|
(in-package #:ml-survey/survey)
|
|
|
|
(defparameter *use-cdn* nil)
|
|
|
|
(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)
|
|
(ml-survey/fileops:ensure-surveys-dir)))
|
|
(setf properties (first (rest (assoc (parse-integer id)
|
|
(ml-survey/fileops:read-from-file (ml-survey/fileops: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."))
|
|
|
|
(defgeneric survey-properties-title (survey)
|
|
(:documentation "Get title property."))
|
|
|
|
(defgeneric survey-properties-description (survey)
|
|
(:documentation "Get description property."))
|
|
|
|
(defmethod survey-id-p ((survey survey))
|
|
(let ((ids (mapcar #'car (read-from-file (ml-survey/fileops: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-properties-title ((survey survey))
|
|
(cdr (assoc "title" (survey-properties survey) :test #'string-equal)))
|
|
|
|
(defmethod survey-properties-description ((survey survey))
|
|
(cdr (assoc "description" (survey-properties survey) :test #'string-equal)))
|
|
|
|
(defun build-questionnaire-link (survey-id resource)
|
|
(format nil "/survey/~a~a" survey-id resource))
|
|
|
|
(defmethod survey-html ((survey survey))
|
|
(spinneret:with-html
|
|
(:dl (loop for property in (survey-properties survey)
|
|
for key = (car property)
|
|
for value = (cdr property) do
|
|
(:dt key)
|
|
(cond ((string= key "questionnaire")
|
|
(:dd (:a :href (build-questionnaire-link (survey-id survey) value)
|
|
(format nil "Open Questionnaire ~a" value))))
|
|
(t (:dd value)))))))
|
|
|
|
(defun view (survey &optional assessments)
|
|
"Generates the view to show the survey created."
|
|
(check-type survey survey)
|
|
(with-page (:title "Survey Details")
|
|
(body-header t "Survey Details"
|
|
(with-navbar (:brand "ml-survey" :active-item "New Survey")
|
|
"Home" "/" "New Survey" "/new-survey"))
|
|
(body-main t
|
|
(with-section (with-title-bar "Properties")
|
|
(:p (format nil "ID: ~a" (survey-id survey)))
|
|
(survey-html survey))
|
|
|
|
(with-section (with-title-bar "Assesments")
|
|
(loop for assessment in assessments
|
|
when assessments
|
|
do (assessment-render-results assessment))))))
|
|
|
|
(defun nps-calc (time-data)
|
|
"Calculate the Net Promoter Score (NPS) from a list of SCORES."
|
|
(check-type time-data list)
|
|
(let ((promoters 0)
|
|
(detractors 0)
|
|
(total-responses (length time-data)))
|
|
(dolist (data (cdr time-data))
|
|
(cond
|
|
((>= data 9) (incf promoters))
|
|
((<= data 6) (incf detractors))))
|
|
(let ((nps (* (- (/ promoters total-responses)
|
|
(/ detractors total-responses))
|
|
100)))
|
|
nps)))
|
|
|
|
(defstruct questionnaire-result
|
|
type
|
|
name
|
|
timestamp
|
|
post-data)
|
|
|
|
(defun questionnaire-result-list-p (list)
|
|
"Check if all elements in LIST are of type 'questionnaire-result'."
|
|
(if (every 'questionnaire-result-p list) t nil))
|
|
|
|
(deftype questionnaire-result-list ()
|
|
"Define a type representing a list containing only questionnaire-result instances."
|
|
'(and list (satisfies questionnaire-result-list-p)))
|
|
|
|
(defun questionnaire-result-from-file (filename)
|
|
"Create a 'questionnaire-result' instance from data read from the file specified by FILENAME."
|
|
(check-type filename (or string pathname))
|
|
(let ((data (ml-survey/fileops:read-from-file filename)))
|
|
(make-questionnaire-result :type (getf data :type)
|
|
:name (getf data :name)
|
|
:timestamp (getf data :timestamp)
|
|
:post-data (getf data :post-data))))
|
|
|
|
(defun string->keyword (string)
|
|
(intern (string-upcase string) :keyword))
|
|
|
|
(defun list-of-categorized-results (result-objs)
|
|
"Collecting questionnaire results listed in RESULT-OBJs."
|
|
(declare (type questionnaire-result-list result-objs))
|
|
|
|
(let ((categorized-results (list)))
|
|
|
|
(dolist (result result-objs categorized-results)
|
|
|
|
(let ((name (string->keyword (questionnaire-result-name result)))
|
|
(data (questionnaire-result-post-data result))
|
|
(timestamp (questionnaire-result-timestamp result)))
|
|
|
|
(setf (getf categorized-results name)
|
|
(push (cons timestamp data)
|
|
(getf categorized-results name)))))))
|
|
|
|
(defun survey-uri-p (uri)
|
|
(let ((parts (ml-survey/app:split-uri uri)))
|
|
(and (= (length parts) 2)
|
|
(string= (first parts) "survey")
|
|
(every #'digit-char-p (second parts)))))
|
|
|
|
(defun survey-uri (request)
|
|
(survey-uri-p (hunchentoot:request-uri request)))
|
|
|
|
(define-easy-handler (survey-handler :uri #'survey-uri) ()
|
|
(let* ((s (make-instance 'survey
|
|
:id (ml-survey/app:extract-from (hunchentoot:request-uri*) :survey-id)))
|
|
(result-objs (mapcar 'questionnaire-result-from-file
|
|
(survey-data-dir-files s)))
|
|
(categorized-results (list-of-categorized-results result-objs))
|
|
(assessments (parse-assessment categorized-results)))
|
|
(view s assessments)))
|