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

Big refactoring

Browse source
This commit is contained in:
Marcus Kammer 2024-07-09 20:23:19 +02:00
parent 739244d21c
commit ea0b1bef43
Signed by: marcuskammer
GPG key ID: C374817BE285268F
23 changed files with 389 additions and 448 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
dev.metalisp.survey.asd
View file

@ -2,38 +2,19 @@
(defsystem "dev.metalisp.survey"
:description "A simple survey"
:version "0.1.13"
:version "0.2.0"
:author "Marcus Kammer <marcus.kammer@metalisp.dev"
:source-control "git@git.sr.ht:~marcuskammer/dev.metalisp.survey"
:licence "MIT"
:depends-on
("local-time" "hunchentoot" "dev.metalisp.sbt")
:components
((:module "src"
:components
((:file "package")
(:file "fileops")
((:file "fileops")
(:file "navbar")
(:file "app")
(:file "survey")
(:file "questionnaire")))
(:module "src/views"
:components
((:file "package")
(:file "_navbar")
(:file "main")
(:file "questionnaire")
(:file "new-survey")
(:file "survey")
(:file "surveys")
(:file "questionnaire-submit")))
(:module "src/handlers"
:components
((:file "package")
(:file "main")
(:file "new-survey")
(:file "survey")
(:file "surveys")
(:file "questionnaire")))))
(:file "new-survey")))))

63
src/app.lisp
View file

@ -1,9 +1,66 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey)
(defpackage ml-survey/app
(:use #:cl)
(:export #:extract-from
#:*html-lang*
#:generate-uuid
#:split-uri
#:today+now
#:*app*
#:start))
(in-package #:ml-survey/app)
(defparameter *html-lang* "en")
(defparameter *use-cdn* nil)
(defparameter *url-key-map*
'((:survey-id . 1)
(:language . 2)
(:questionnaire . 3)))
(defun split-uri (uri)
(check-type uri string)
(remove-if #'string-empty-p
(uiop:split-string uri :separator "/")))
(defun extract-from (url key)
(let* ((parts (split-uri url))
(index (cdr (assoc key *url-key-map*))))
(when (and parts index)
(nth index parts))))
(defun today ()
"Return today's date formatted as ISO-8601."
(local-time:format-timestring nil
(local-time:now)
:format '(:year "-" (:month 2) "-" (:day 2))))
(defun now ()
"Return current time formatted as ISO-8601."
(local-time:format-timestring nil
(local-time:now)
:format '((:hour 2) ":" (:min 2) ":" (:sec 2))))
(defun today+now ()
(format nil "~a ~a" (today) (now)))
(defun generate-uuid ()
(parse-integer (format nil "~A~A~A"
(sb-posix:getpid)
(get-universal-time)
(random 1000000))))
(defun generate-random-id (length)
(let ((charset "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"))
(coerce (loop repeat length
collect (char charset (random (length charset))))
'string)))
(defun string-empty-p (string) (= (length string) 0))
(defun set-default-directory (directory)
(setf *default-pathname-defaults* (truename (merge-pathnames directory))))
@ -31,9 +88,9 @@
(defvar *app* (create-server 'app
8080
:document-root
(public-dir)
(ml-survey/fileops:public-dir)
:access-log-destination
(access-log-file)))
(ml-survey/fileops:access-log-file)))
(defun start ()
(start-server *app*))

33
src/fileops.lisp
View file

@ -1,6 +1,21 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey)
(defpackage ml-survey/fileops
(:use #:cl)
(:export #:public-dir
#:access-log-file
#:read-from-file
#:write-to-file
#:ensure-questionnaires-dir
#:ensure-data-file-exist
#:ensure-surveys-dir
#:make-db-file
#:extract-lang-and-filename
#:questionnaires-list-files
#:questionnaires-dir
#:make-surveys-db-file))
(in-package #:ml-survey/fileops)
(defun data-dir ()
"Construct and return the directory path for storing data within the
@ -35,6 +50,19 @@ path."
(defun questionnaires-list-files ()
(uiop:directory* (format nil "~a*/*.lisp" (questionnaires-dir))))
(defun find-next-directory (dir-list target)
(let ((index (position target dir-list :test #'string=)))
(when index
(nth (1+ index) dir-list))))
(defun extract-lang-and-filename (path &optional (target-dir "questionnaires"))
(let* ((directory (pathname-directory path))
(name (pathname-name path))
(lang (find-next-directory directory target-dir)))
(if lang
(format nil "/~A/~A" lang name)
(format nil "/~A" name))))
(defun ensure-file-exist (pathname)
"Ensure that a file specified by PATHNAME exists, create it if it doesn't."
(unless (uiop:file-exists-p pathname)
@ -86,3 +114,6 @@ within the data directory."
(ensure-directories-exist (public-dir))
(format t "~%App Data Directory: ~a~%" (data-dir))
(defun make-surveys-db-file ()
(make-db-file "surveys-db.lisp"))

48
src/handlers/main.lisp
View file

@ -1,48 +0,0 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey/handlers)
(defparameter *url-key-map*
'((:survey-id . 1)
(:language . 2)
(:questionnaire . 3)))
(defun split-uri (uri)
(check-type uri string)
(remove-if #'string-empty-p
(uiop:split-string uri :separator "/")))
(defun extract-from (url key)
(let* ((parts (split-uri url))
(index (cdr (assoc key *url-key-map*))))
(when (and parts index)
(nth index parts))))
(defun today ()
"Return today's date formatted as ISO-8601."
(local-time:format-timestring nil
(local-time:now)
:format '(:year "-" (:month 2) "-" (:day 2))))
(defun now ()
"Return current time formatted as ISO-8601."
(local-time:format-timestring nil
(local-time:now)
:format '((:hour 2) ":" (:min 2) ":" (:sec 2))))
(defun today+now ()
(format nil "~a ~a" (today) (now)))
(defun generate-uuid ()
(parse-integer (format nil "~A~A~A"
(sb-posix:getpid)
(get-universal-time)
(random 1000000))))
(defun generate-random-id (length)
(let ((charset "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"))
(coerce (loop repeat length
collect (char charset (random (length charset))))
'string)))
(defun string-empty-p (string) (= (length string) 0))

19
src/handlers/new-survey.lisp
View file

@ -1,19 +0,0 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey/handlers)
(defun process-new-survey-get ()
(ml-survey/views:new-survey))
(defun process-new-survey-post (request)
(let ((post-params (post-parameters* request))
(uid (generate-uuid))
(stored-surveys (read-from-file (make-surveys-db-file))))
(write-to-file (make-surveys-db-file) (push (list uid post-params) stored-surveys))
(ml-survey/views:new-survey uid)))
(define-easy-handler (new-survey :uri "/new-survey") nil
(cond ((eq (hunchentoot:request-method*) :get)
(process-new-survey-get))
((eq (hunchentoot:request-method*) :post)
(process-new-survey-post *request*))))

19
src/handlers/package.lisp
View file

@ -1,19 +0,0 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(defpackage ml-survey/handlers
(:use #:cl)
(:import-from #:spinneret
#:*html*)
(:import-from #:hunchentoot
#:define-easy-handler
#:post-parameters*
#:content-type*
#:request-uri
#:request-uri*
#:*request*)
(:import-from #:ml-survey
#:ensure-data-dir
#:ensure-data-file-exist
#:write-to-file
#:read-from-file
#:make-surveys-db-file))

43
src/handlers/questionnaire.lisp
View file

@ -1,43 +0,0 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey/handlers)
(defun questionnaire-uri-p (uri)
"Check if the request URI matches the pattern '/survey/<numeric>/lang/type'"
(let ((parts (split-uri uri)))
(and (= (length parts) 4)
(string= (first parts) "survey")
(every #'digit-char-p (second parts))
(= 2 (length (third parts))))))
(defun questionnaire-uri (request)
(questionnaire-uri-p (request-uri request)))
(defun process-questionnaire-get (lang questionnaire)
(check-type lang string)
(setf ml-survey:*html-lang* lang)
(ml-survey/views:questionnaire questionnaire))
(defun process-questionnaire-post (request survey questionnaire)
(let* ((post-params (post-parameters* request))
(survey-id (ml-survey:survey-id survey))
(questionnaire-id (generate-uuid))
(questionnaire-data-file (ensure-data-file-exist survey-id
questionnaire-id)))
(write-to-file questionnaire-data-file
(list :type questionnaire
:timestamp (today+now)
:post-data post-params))
(ml-survey/views:questionnaire-submit)))
(define-easy-handler (questionnaire :uri #'questionnaire-uri) nil
(let ((s (make-instance 'ml-survey:survey
:id (extract-from (request-uri*) :survey-id)))
(language (extract-from (request-uri*) :language))
(questionnaire (extract-from (request-uri*) :questionnaire)))
(cond ((eq (hunchentoot:request-method*) :get)
(process-questionnaire-get language questionnaire))
((eq (hunchentoot:request-method*) :post)
(process-questionnaire-post *request* s questionnaire)))))

37
src/handlers/survey.lisp
View file

@ -1,37 +0,0 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey/handlers)
(defun list-of-categorized-results (result-objs)
"Categorize results into different lists based on their type.
Apply special calculation for results of type 'sus'."
(let ((categorized-results (list :sus nil)))
(dolist (result result-objs categorized-results)
(let ((type (intern (string-upcase (ml-survey::questionnaire-result-type result)) :keyword))
(data (ml-survey::questionnaire-result-post-data result))
(timestamp (ml-survey::questionnaire-result-timestamp result)))
(cond
((eq type :sus)
(setf (getf categorized-results :sus)
(cons (ml-survey:sus-calc (cons timestamp data))
(getf categorized-results :sus))))
(t
(setf (getf categorized-results type)
(cons (cons timestamp (mapcar #'cdr data))
(getf categorized-results type)))))))))
(defun survey-uri-p (uri)
(let ((parts (split-uri uri)))
(and (= (length parts) 2)
(string= (first parts) "survey")
(every #'digit-char-p (second parts)))))
(defun survey-uri (request)
(survey-uri-p (request-uri request)))
(define-easy-handler (survey :uri #'survey-uri) ()
(let* ((s (make-instance 'ml-survey:survey
:id (extract-from (request-uri*) :survey-id)))
(result-objs (mapcar #'ml-survey:questionnaire-result-from-file
(ml-survey:survey-data-dir-files s))))
(ml-survey/views:survey s (list-of-categorized-results result-objs))))

11
src/handlers/surveys.lisp
View file

@ -1,11 +0,0 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey/handlers)
(define-easy-handler (surveys :uri "/") nil
(let* ((survey-db (read-from-file (make-surveys-db-file)))
(list-of-surveys (mapcar (lambda (x)
(make-instance 'ml-survey:survey
:id (format nil "~a" (first x))))
survey-db)))
(ml-survey/views:surveys list-of-surveys)))

6
src/views/_navbar.lisp → src/navbar.lisp
View file

@ -1,6 +1,10 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey/views)
(defpackage ml-survey/navbar
(:use :cl)
(:export #:navbar-en))
(in-package :ml-survey/navbar)
(defmacro navbar-brand (src width)
`(spinneret:with-html

39
src/views/new-survey.lisp → src/new-survey.lisp
View file

@ -1,12 +1,24 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey/views)
(defpackage ml-survey/new-survey
(:use :cl)
(:import-from #:hunchentoot
#:define-easy-handler)
(:import-from #:dev.metalisp.sbt
#:with-page
#:body-header))
(defun new-survey (&optional survey-id)
(in-package :ml-survey/new-survey)
(defun list-questionnaires ()
(mapcar #'ml-survey/fileops:extract-lang-and-filename
(ml-survey/fileops:questionnaires-list-files)))
(defun view (&optional survey-id)
"Generates the view to create a new survey."
(let ((questionnaires (ml-survey:list-questionnaires)))
(let ((questionnaires (list-questionnaires)))
(with-page (:title "New Survey")
(body-header "New Survey" (navbar-en))
(body-header "New Survey" (ml-survey/navbar:navbar-en))
(:main :class "container"
:id "main-content"
@ -16,7 +28,7 @@
(:div :class "alert alert-warning"
:role "alert"
(format nil "There are no questionnaires available.~%
The folder: ~a is empty." (ml-survey:questionnaires-dir))))
The folder: ~a is empty." (ml-survey/fileops:questionnaires-dir))))
;; When a new survey was created, show the user an info message.
(when survey-id
@ -63,3 +75,20 @@
(:button :type"Submit"
:class "btn btn-primary"
"Create Survey"))))))
(defun process-new-survey-get ()
(view))
(defun process-new-survey-post (request)
(let ((post-params (hunchentoot:post-parameters* request))
(uid (ml-survey/app:generate-uuid))
(stored-surveys (ml-survey/fileops:read-from-file (ml-survey/fileops:make-surveys-db-file))))
(ml-survey/fileops:write-to-file (ml-survey/fileops:make-surveys-db-file)
(push (list uid post-params) stored-surveys))
(view uid)))
(define-easy-handler (new-survey-handler :uri "/new-survey") nil
(cond ((eq (hunchentoot:request-method*) :get)
(process-new-survey-get))
((eq (hunchentoot:request-method*) :post)
(process-new-survey-post hunchentoot:*request*))))

36
src/package.lisp
View file

@ -1,36 +0,0 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(defpackage ml-survey
(:use #:cl)
(:import-from #:hunchentoot
#:easy-acceptor)
(:export
#:main
#:*html-lang*
#:survey
#:survey-id
#:survey-data-dir-p
#:survey-data-dir-files
#:survey-html
#:survey-properties
#:survey-properties-title
#:survey-properties-description
#:ensure-data-dir
#:ensure-data-file-exist
#:ensure-questionnaires-dir
#:questionnaires-dir
#:questionnaires-list-files
#:extract-lang-and-filename
#:list-questionnaires
#:questionnaire-result
#:questionnaire-result-from-file
#:sus-calc
#:write-to-file
#:read-from-file
#:make-surveys-db-file
#:start
#:*app*
#:set-default-directory
#:start-server
#:stop-server
#:restart-server))

141
src/questionnaire.lisp
View file

@ -1,57 +1,106 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey)
(defpackage ml-survey/questionnaire
(:use :cl)
(:import-from #:hunchentoot
#:define-easy-handler)
(:import-from #:dev.metalisp.sbt
#:find-l10n
#:*l10n*
#:*use-cdn*
#:with-page
#:body-header
#:body-main)
(:import-from #:dev.metalisp.sbt/btn
#:btn
#:btn-primary)
(:import-from #:dev.metalisp.sbt/form
#:multi-form)
(:import-from #:dev.metalisp.sbt/utility
#:spacing))
(defun find-next-directory (dir-list target)
(let ((index (position target dir-list :test #'string=)))
(when index
(nth (1+ index) dir-list))))
(in-package :ml-survey/questionnaire)
(defun extract-lang-and-filename (path &optional (target-dir "questionnaires"))
(let* ((directory (pathname-directory path))
(name (pathname-name path))
(lang (find-next-directory directory target-dir)))
(if lang
(format nil "/~A/~A" lang name)
(format nil "/~A" name))))
(defun load-form (lang questionnaire)
"Load a Lisp file containing form definitions."
(check-type lang string)
(check-type questionnaire string)
(let* ((form-path (uiop:merge-pathnames* (format nil "~a/~a.lisp" lang questionnaire)
(ml-survey/fileops:ensure-questionnaires-dir))))
(unless (probe-file form-path)
(error "Form file ~A does not exist." form-path))
(load form-path))
nil)
(defun list-questionnaires ()
(mapcar #'extract-lang-and-filename (questionnaires-list-files)))
(defmacro with-form (&body body)
"Create a standardized HTML form wrapped in a <main> tag with a pre-defined
class and structure, using the Spinneret library. The form is designed to be
used within a web application served by Hunchentoot, utilizing common layout
and localization practices. The macro automatically sets the form’s action to
the current request URI and expects certain functions and variables to be
available in its environment for full functionality."
`(spinneret:with-html
(:main :id "main-content"
:class "container my-5"
(:p "Please fill out the following forms and press the submit button.")
;; action is defined as hunchentoot:request-uri* function
(:form :action (hunchentoot:request-uri*)
:method "post"
:class (spacing :property "m" :side "y" :size 5)
,@body
(btn-primary (:type "submit")
(find-l10n "submit" ml-survey/app:*html-lang* *l10n*))))))
(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))
(defun view (questionnaire)
(with-page (:title "SUS Form" :add-js-urls ("/app.js"))
(body-header "System Usability Form")
(with-form (load-form ml-survey/app:*html-lang* questionnaire))))
(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)))
(defun view-submit ()
(with-page (:title "Confirmation")
(body-header "Confirmation")
(:main :id "main-content"
:class "container"
(:div :class "alert alert-info"
:role "alert"
"Thank you for filling out the questionnaire."))))
(defun sus-calc-score-per-row (results)
(check-type results list)
(reverse (cons (* (apply #'+ (sus-calc-score results)) 2.5) (reverse results))))
(defun questionnaire-uri-p (uri)
"Check if the request URI matches the pattern '/survey/<numeric>/lang/type'"
(let ((parts (ml-survey/app:split-uri uri)))
(and (= (length parts) 4)
(string= (first parts) "survey")
(every #'digit-char-p (second parts))
(= 2 (length (third parts))))))
(defun sus-calc (files)
(check-type files list)
(cons (car files) (sus-calc-score-per-row (extract-numbers (cdr files)))))
(defun questionnaire-uri (request)
(questionnaire-uri-p (hunchentoot:request-uri request)))
(defstruct questionnaire-result
type
timestamp
post-data)
(defun process-questionnaire-get (lang questionnaire)
(check-type lang string)
(setf ml-survey/app:*html-lang* lang)
(view questionnaire))
(defun questionnaire-result-from-file (filename)
(check-type filename (or string pathname))
(let ((data (read-from-file filename)))
(make-questionnaire-result :type (getf data :type)
:timestamp (getf data :timestamp)
:post-data (getf data :post-data))))
(defun process-questionnaire-post (request survey questionnaire)
(let* ((post-params (hunchentoot:post-parameters* request))
(survey-id (ml-survey/survey:survey-id survey))
(questionnaire-id (ml-survey/app:generate-uuid))
(questionnaire-data-file (ml-survey/fileops:ensure-data-file-exist survey-id
questionnaire-id)))
(ml-survey/fileops:write-to-file questionnaire-data-file
(list :type questionnaire
:timestamp (ml-survey/app:today+now)
:post-data post-params))
(view-submit)))
(define-easy-handler (questionnaire-handler :uri #'questionnaire-uri) nil
(let ((s (make-instance 'ml-survey/survey:survey
:id (ml-survey/app:extract-from (hunchentoot:request-uri*) :survey-id)))
(language (ml-survey/app:extract-from (hunchentoot:request-uri*) :language))
(questionnaire (ml-survey/app:extract-from (hunchentoot:request-uri*) :questionnaire)))
(cond ((eq (hunchentoot:request-method*) :get)
(process-questionnaire-get language questionnaire))
((eq (hunchentoot:request-method*) :post)
(process-questionnaire-post hunchentoot:*request* s questionnaire)))))

4
src/views/questionnaires/de/sus.lisp → src/questionnaires/de/sus.lisp
View file

@ -1,6 +1,4 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey/views)
(in-package :ml-survey/questionnaire)
(multi-form
(:ask "Ich denke, dass ich dieses System häufig nutzen möchte."

4
src/views/questionnaires/en/demo.lisp → src/questionnaires/en/demo.lisp
View file

@ -1,6 +1,4 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey/views)
(in-package :ml-survey/questionnaire)
(multi-form
(:ask "What is your age range?"

4
src/views/questionnaires/en/sus.lisp → src/questionnaires/en/sus.lisp
View file

@ -1,6 +1,4 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey/views)
(in-package :ml-survey/questionnaire)
(multi-form
(:ask "I would like to use this system frequently."

139
src/survey.lisp
View file

@ -1,9 +1,18 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey)
(defpackage ml-survey/survey
(:use #:cl)
(:import-from #:hunchentoot
#:define-easy-handler)
(:import-from #:dev.metalisp.sbt
#:with-page
#:body-header)
(:export #:survey-id
#:survey
#:survey-properties-title
#:survey-properties-description))
(defun make-surveys-db-file ()
(make-db-file "surveys-db.lisp"))
(in-package #:ml-survey/survey)
(defclass survey ()
((id :initarg :id :reader survey-id)
@ -14,9 +23,9 @@
(with-slots (id data-dir properties) survey
(setf data-dir (uiop:merge-pathnames*
(format nil "~a/" id)
(ensure-surveys-dir)))
(ml-survey/fileops:ensure-surveys-dir)))
(setf properties (first (rest (assoc (parse-integer id)
(read-from-file (make-surveys-db-file))))))))
(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."))
@ -34,7 +43,7 @@
(:documentation "Get description property."))
(defmethod survey-id-p ((survey survey))
(let ((ids (mapcar #'car (read-from-file (make-surveys-db-file)))))
(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))
@ -62,3 +71,121 @@
(:dd (:a :href (build-questionnaire-link (survey-id survey) value)
(format nil "Open Questionnaire ~a" value))))
(t (:dd value)))))))
(defun results-not-null (results)
(some (lambda (x) (and (listp x) (not (null x)))) results))
(defun view (survey &optional results)
"Generates the view to show the survey created."
(check-type survey survey)
(let ((results-not-null (results-not-null results))
(sus-results (getf results :sus)))
(with-page (:title "Survey Details" :add-js-urls ("/app.js"))
(body-header "Survey Details" (ml-survey/navbar:navbar-en))
(:main :id "main-content"
:class "container"
(:p (format nil "ID: ~a" (survey-id survey)))
(:h2 :class "py-3" "Properties")
(survey-html survey)
(when results-not-null
(:h2 :class "py-3" "Questionnaire Results")
(if sus-results
(let ((count-answers (length (cdr (car sus-results)))))
(:h3 :class "py-1" "SUS")
(:table :class "table table-hover"
(:caption "Questionnaire results table")
(:thead
(:tr
(:th :scope "col" "Time")
(loop for header from 1 below count-answers
do (:th :scope "col" (format nil "Q ~a" header)))
(:th :scope "col" "SUS Score")))
(:tbody
(loop for row in sus-results
do (:tr (mapcar (lambda (data) (:td data)) row)))))))
(loop for (type data) on results by #'cddr unless (eq type :sus)
do (progn (:h3 :class "py-1" (format nil "~a" type))
(loop for row in data
do (:ul :class "list-group py-3"
(loop for data in row
for i from 0
do (:li :class (if (zerop i)
"list-group-item active"
"list-group-item")
data)))))))))))
(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))
(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)))
(defun sus-calc-score-per-row (results)
(check-type results list)
(reverse (cons (* (apply #'+ (sus-calc-score results)) 2.5) (reverse results))))
(defun sus-calc (files)
(check-type files list)
(cons (car files) (sus-calc-score-per-row (extract-numbers (cdr files)))))
(defstruct questionnaire-result
type
timestamp
post-data)
(defun questionnaire-result-from-file (filename)
(check-type filename (or string pathname))
(let ((data (ml-survey/fileops:read-from-file filename)))
(make-questionnaire-result :type (getf data :type)
:timestamp (getf data :timestamp)
:post-data (getf data :post-data))))
(defun list-of-categorized-results (result-objs)
"Categorize results into different lists based on their type.
Apply special calculation for results of type 'sus'."
(let ((categorized-results (list :sus nil)))
(dolist (result result-objs categorized-results)
(let ((type (intern (string-upcase (questionnaire-result-type result)) :keyword))
(data (questionnaire-result-post-data result))
(timestamp (questionnaire-result-timestamp result)))
(cond
((eq type :sus)
(setf (getf categorized-results :sus)
(cons (sus-calc (cons timestamp data))
(getf categorized-results :sus))))
(t
(setf (getf categorized-results type)
(cons (cons timestamp (mapcar #'cdr data))
(getf categorized-results type)))))))))
(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))))
(view s (list-of-categorized-results result-objs))))

30
src/views/surveys.lisp → src/surveys.lisp
View file

@ -1,21 +1,29 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey/views)
(defpackage ml-survey/surveys
(:use :cl)
(:import-from #:hunchentoot
#:define-easy-handler)
(:import-from #:dev.metalisp.sbt
#:body-header
#:with-page))
(in-package :ml-survey/surveys)
(defun surveys-p (list)
"Check if all elements in `lst` are instances of the class `survey`."
(every (lambda (item) (typep item 'ml-survey:survey)) list))
(every (lambda (item) (typep item 'ml-survey/survey:survey)) list))
(deftype surveys-list ()
'(and list (satisfies surveys-p)))
(defun surveys (surveys)
(defun view (surveys)
"Generates the view to show all surveys available.
SURVEYS: List of survey objects."
(check-type surveys surveys-list)
(with-page (:title "Surveys" :add-js-urls ("/app.js"))
(body-header "Surveys" (navbar-en))
(body-header "Surveys" (ml-survey/navbar:navbar-en))
(:main :id "main-content"
:class "container"
(:div :class "btn-toolbar my-3"
@ -27,9 +35,9 @@ SURVEYS: List of survey objects."
(:h2 :class "mb-3" "Overview")
(:ol :class "list-group list-group-numbered"
(loop for survey in surveys
for title = (ml-survey:survey-properties-title survey)
for description = (ml-survey:survey-properties-description survey)
for id = (ml-survey:survey-id survey) do
for title = (ml-survey/survey:survey-properties-title survey)
for description = (ml-survey/survey:survey-properties-description survey)
for id = (ml-survey/survey:survey-id survey) do
(:li :class "list-group-item d-flex justify-content-between align-items-start"
(:div :class "ms-2 me-auto"
(:a :class "fw-bold clearfix"
@ -38,3 +46,11 @@ SURVEYS: List of survey objects."
(if description
(:span description)
nil)))))))))
(define-easy-handler (surveys-handler :uri "/") nil
(let* ((survey-db (ml-survey/fileops:read-from-file (ml-survey/fileops:make-surveys-db-file)))
(list-of-surveys (mapcar (lambda (x)
(make-instance 'ml-survey/survey:survey
:id (format nil "~a" (first x))))
survey-db)))
(view list-of-surveys)))

5
src/views/main.lisp
View file

@ -1,5 +0,0 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey/views)
(defparameter *use-cdn* nil)

30
src/views/package.lisp
View file

@ -1,30 +0,0 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(defpackage ml-survey/views
(:use #:cl)
(:import-from #:hunchentoot
#:request-uri*)
(:import-from #:spinneret
#:*html*)
(:import-from #:dev.metalisp.sbt
#:find-l10n
#:*l10n*
#:*use-cdn*
#:with-page
#:body-header
#:body-main)
(:import-from #:dev.metalisp.sbt/btn
#:btn
#:btn-primary)
(:import-from #:dev.metalisp.sbt/form
#:multi-form)
(:import-from #:dev.metalisp.sbt/utility
#:spacing)
(:export #:index
#:imprint
#:new-survey
#:surveys
#:create-survey
#:survey
#:questionnaire-submit
#:questionnaire))

12
src/views/questionnaire-submit.lisp
View file

@ -1,12 +0,0 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey/views)
(defun questionnaire-submit ()
(with-page (:title "Confirmation")
(body-header "Confirmation")
(:main :id "main-content"
:class "container"
(:div :class "alert alert-info"
:role "alert"
"Thank you for filling out the questionnaire."))))

38
src/views/questionnaire.lisp
View file

@ -1,38 +0,0 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey/views)
(defun load-form (lang questionnaire)
"Load a Lisp file containing form definitions."
(check-type lang string)
(check-type questionnaire string)
(let* ((form-path (uiop:merge-pathnames* (format nil "~a/~a.lisp" lang questionnaire)
(ml-survey:ensure-questionnaires-dir))))
(unless (probe-file form-path)
(error "Form file ~A does not exist." form-path))
(load form-path))
nil)
(defmacro with-form (&body body)
"Create a standardized HTML form wrapped in a <main> tag with a pre-defined
class and structure, using the Spinneret library. The form is designed to be
used within a web application served by Hunchentoot, utilizing common layout
and localization practices. The macro automatically sets the form’s action to
the current request URI and expects certain functions and variables to be
available in its environment for full functionality."
`(spinneret:with-html
(:main :id "main-content"
:class "container my-5"
(:p "Please fill out the following forms and press the submit button.")
;; action is defined as hunchentoot:request-uri* function
(:form :action (request-uri*)
:method "post"
:class (spacing :property "m" :side "y" :size 5)
,@body
(btn-primary (:type "submit")
(find-l10n "submit" ml-survey:*html-lang* *l10n*))))))
(defun questionnaire (questionnaire)
(with-page (:title "SUS Form" :add-js-urls ("/app.js"))
(body-header "System Usability Form")
(with-form (load-form ml-survey:*html-lang* questionnaire))))

49
src/views/survey.lisp
View file

@ -1,49 +0,0 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(in-package :ml-survey/views)
(defun results-not-null (results)
(some (lambda (x) (and (listp x) (not (null x)))) results))
(defun survey (survey &optional results)
"Generates the view to show the survey created."
(check-type survey ml-survey:survey)
(let ((results-not-null (results-not-null results))
(sus-results (getf results :sus)))
(with-page (:title "Survey Details" :add-js-urls ("/app.js"))
(body-header "Survey Details" (navbar-en))
(:main :id "main-content"
:class "container"
(:p (format nil "ID: ~a" (ml-survey:survey-id survey)))
(:h2 :class "py-3" "Properties")
(ml-survey:survey-html survey)
(when results-not-null
(:h2 :class "py-3" "Questionnaire Results")
(if sus-results
(let ((count-answers (length (cdr (car sus-results)))))
(:h3 :class "py-1" "SUS")
(:table :class "table table-hover"
(:caption "Questionnaire results table")
(:thead
(:tr
(:th :scope "col" "Time")
(loop for header from 1 below count-answers
do (:th :scope "col" (format nil "Q ~a" header)))
(:th :scope "col" "SUS Score")))
(:tbody
(loop for row in sus-results
do (:tr (mapcar (lambda (data) (:td data)) row)))))))
(loop for (type data) on results by #'cddr unless (eq type :sus)
do (progn (:h3 :class "py-1" (format nil "~a" type))
(loop for row in data
do (:ul :class "list-group py-3"
(loop for data in row
for i from 0
do (:li :class (if (zerop i)
"list-group-item active"
"list-group-item")
data)))))))))))