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

Update models package with survey model

Browse source
This commit is contained in:
Marcus Kammer 2025-02-15 12:19:39 +01:00
parent 429c862ff0
commit 08462193f6
Signed by: marcuskammer
GPG key ID: C374817BE285268F
9 changed files with 113 additions and 79 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
dev.metalisp.survey.asd
View file

@ -2,7 +2,7 @@
(defsystem "dev.metalisp.survey"
:description "Create questionnaires and analyze the results."
:version "0.5.12"
:version "0.5.13"
:author "Marcus Kammer <marcus.kammer@mailbox.org>"
:source-control (:git "https://code.metalisp.dev/marcuskammer/dev.metalisp.survey.git")
:licence "MIT"
@ -10,11 +10,16 @@
:components ((:module "src/"
:components ((:file "fileops")
(:file "app")
(:file "survey")
(:module "questionnaire/"
(:module "models/"
:serial t
:components ((:file "package")
(:file "survey")
(:file "questionnaire")))
(:file "survey")
(:module "questionnaire/"
:depends-on ("models/")
:serial t
:components ((:file "package")
(:file "model")
(:file "view")
(:file "handler")))
(:file "surveys")

18
src/models/package.lisp Normal file
View file

@ -0,0 +1,18 @@
;;; -*- mode: lisp; coding: utf-8; -*-
(defpackage :ml-survey/models
(:use #:cl)
(:export #:survey-id
#:survey-id-p
#:survey
#:survey-data-dir
#:survey-data-dir-files
#:survey-data-dir-p
#:survey-properties
#:survey-properties-title
#:survey-properties-description
#:survey-html
#:questionnaire
#:questionnaire-name
#:questionnaire-type
#:questionnaire-lang
#:create-questionnaire-data))

13
src/models/questionnaire.lisp Normal file
View file

@ -0,0 +1,13 @@
;;; -*- mode: lisp; coding: utf-8; -*-
(in-package :ml-survey/models)
(defclass questionnaire ()
((name :initarg :name :reader questionnaire-name)
(type :initarg :type :reader questionnaire-type)
(lang :initarg :lang :reader questionnaire-lang)))
(defmethod create-questionnaire-data ((q questionnaire) post-params)
(list :type (questionnaire-type q)
:name (questionnaire-name q)
:timestamp (ml-survey/app:today+now)
:post-data post-params))

61
src/models/survey.lisp Normal file
View file

@ -0,0 +1,61 @@
;;; -*- mode: lisp; coding: utf-8; -*-
(in-package :ml-survey/models)
(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
(when (not (integerp id))
(setf id (handler-case (parse-integer id) (error () nil))))
(setf data-dir (uiop:merge-pathnames*
(format nil "~a/" id)
(ml-survey/fileops:ensure-surveys-dir)))
(setf properties (first (rest (assoc id (ml-survey/fileops:surveys-db)))))))
(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 #'first (ml-survey/fileops:surveys-db))))
(if (member (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)))))))

2
src/new-survey.lisp
View file

@ -1,7 +1,7 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(defpackage ml-survey/new-survey
(:use :cl)
(:use #:cl #:ml-survey/models)
(:import-from #:hunchentoot
#:define-easy-handler)
(:import-from #:ml-sbt/navbar

4
src/questionnaire/handler.lisp
View file

@ -34,7 +34,7 @@
(defun process-questionnaire-post (post-params survey q)
(declare (type questionnaire q))
(let* ((survey-id (ml-survey/survey:survey-id survey))
(let* ((survey-id (survey-id survey))
(questionnaire-id (ml-survey/app:generate-uuid))
(questionnaire-data-file (ml-survey/fileops:ensure-data-file-exist survey-id questionnaire-id)))
(questionnaire-write-to-file questionnaire-data-file post-params q)
@ -44,7 +44,7 @@
(ml-survey/app:extract-from (hunchentoot:request-uri*) param))
(defun create-survey (survey-id)
(make-instance 'ml-survey/survey:survey :id survey-id))
(make-instance 'survey :id survey-id))
(defun process-request (survey questionnaire)
(ecase (hunchentoot:request-method*)

2
src/questionnaire/package.lisp
View file

@ -1,6 +1,6 @@
;;; -*- mode: lisp; coding: utf-8; -*-
(defpackage :ml-survey/questionnaire
(:use :cl)
(:use #:cl #:ml-survey/models)
(:import-from #:hunchentoot
#:define-easy-handler)
(:import-from #:ml-sbt

67
src/survey.lisp
View file

@ -1,7 +1,7 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(defpackage ml-survey/survey
(:use #:cl)
(:use #:cl #:ml-survey/models)
(:import-from #:hunchentoot
#:define-easy-handler)
(:import-from #:ml-sbt/section
@ -18,73 +18,10 @@
#:with-body-main)
(:import-from #:ml-qmetrics/assessment
#:assessment-html
#:parse-assessments)
(:export #:survey-id
#:survey
#:survey-properties-title
#:survey-properties-description))
#:parse-assessments))
(in-package :ml-survey/survey)
(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
(when (not (integerp id))
(setf id (handler-case (parse-integer id) (error () nil))))
(setf data-dir (uiop:merge-pathnames*
(format nil "~a/" id)
(ml-survey/fileops:ensure-surveys-dir)))
(setf properties (first (rest (assoc id (ml-survey/fileops:surveys-db)))))))
(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 #'first (ml-survey/fileops:surveys-db))))
(if (member (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)

12
src/surveys.lisp
View file

@ -1,7 +1,7 @@
;;;; -*- mode: common-lisp; coding: utf-8; -*-
(defpackage ml-survey/surveys
(:use :cl)
(:use #:cl #:ml-survey/models)
(:import-from #:hunchentoot
#:define-easy-handler)
(:import-from #:ml-sbt/navbar
@ -22,7 +22,7 @@
(defun surveys-p (list)
"Check if all elements in `lst` are instances of the class `survey`."
(every (lambda (item) (typep item 'ml-survey/survey:survey)) list))
(every (lambda (item) (typep item 'survey)) list))
(deftype surveys-list ()
'(and list (satisfies surveys-p)))
@ -43,9 +43,9 @@ SURVEYS: List of survey objects."
(with-title-bar "All Surveys")
(:ol :class "list-group list-group-numbered"
(loop for survey in surveys
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
for title = (survey-properties-title survey)
for description = (survey-properties-description survey)
for id = (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"
@ -57,7 +57,7 @@ SURVEYS: List of survey objects."
(defun list-of-surveys ()
(mapcar (lambda (x)
(make-instance 'ml-survey/survey:survey
(make-instance 'survey
:id (first x)))
(ml-survey/fileops:surveys-db)))