dev.metalisp.survey/src/survey.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)))