177 lines
6.7 KiB
Common Lisp
177 lines
6.7 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-section-col
|
|
#:with-section-row
|
|
#:with-section-props
|
|
#: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-html
|
|
#:parse-assessments)
|
|
(: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)
|
|
(let ((container "container-fluid"))
|
|
(with-page (:title "Survey Details")
|
|
(body-header container "Survey Details"
|
|
(with-navbar container nil
|
|
"Home" "/" "New Survey" "/new-survey"))
|
|
(body-main container
|
|
(:div :class "row"
|
|
(with-section-props (with-title-bar "Properties")
|
|
(:p (format nil "ID: ~a" (survey-id survey)))
|
|
(survey-html survey))
|
|
(with-section-col (with-title-bar "Assesments")
|
|
(loop for assessment in assessments
|
|
when assessments
|
|
do (assessment-html assessment (survey-id survey)))))))))
|
|
|
|
(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-response
|
|
type
|
|
name
|
|
timestamp
|
|
post-data)
|
|
|
|
(defun questionnaire-responses-p (list)
|
|
"Check if all elements in LIST are of type 'questionnaire-result'."
|
|
(if (every 'questionnaire-response-p list) t nil))
|
|
|
|
(deftype questionnaire-responses ()
|
|
"Define a type representing a list containing only questionnaire-result instances."
|
|
'(and list (satisfies questionnaire-responses-p)))
|
|
|
|
(defun questionnaire-response-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-response :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 categorized-responses (responses)
|
|
"Collecting questionnaire results listed in RESULT-OBJs."
|
|
(declare (type questionnaire-responses responses))
|
|
(let ((categorized-responses (list)))
|
|
(dolist (response responses categorized-responses)
|
|
(let ((name (string->keyword (questionnaire-response-name response)))
|
|
(data (questionnaire-response-post-data response))
|
|
(timestamp (questionnaire-response-timestamp response)))
|
|
(setf (getf categorized-responses name)
|
|
(push (cons timestamp data)
|
|
(getf categorized-responses 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* ((survey-id (ml-survey/app:extract-from (hunchentoot:request-uri*) :survey-id))
|
|
(s (make-instance 'survey :id survey-id))
|
|
(responses (mapcar 'questionnaire-response-from-file
|
|
(survey-data-dir-files s)))
|
|
(categorized-responses (categorized-responses responses))
|
|
(assessments (parse-assessments categorized-responses)))
|
|
(view s assessments)))
|