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

Bigger refactoring

Browse source 
In this refactoring I update the survey class and serialize it to the
surveys-db.
This commit is contained in:
Marcus Kammer 2025-02-21 17:58:13 +01:00
parent 034055c2ea
commit 85f56d35c6
Signed by: marcuskammer
GPG key ID: C374817BE285268F
11 changed files with 73 additions and 45 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
dev.metalisp.survey.asd
View file

@ -2,7 +2,7 @@
(defsystem "dev.metalisp.survey"
:description "Create questionnaires and analyze the results."
:version "0.5.37"
:version "0.5.38"
:author "Marcus Kammer <marcus.kammer@mailbox.org>"
:source-control (:git "https://code.metalisp.dev/marcuskammer/dev.metalisp.survey.git")
:licence "MIT"

8
src/create/handler.lisp
View file

@ -6,13 +6,13 @@
(defun process-post (request)
(let* ((post-params (hunchentoot:post-parameters* request))
(uid (ml-survey/app:generate-uuid))
(new-survey (make-survey :properties post-params))
(surveys-db-file (ml-survey/fileops:make-surveys-db-file))
(stored-surveys (ml-survey/fileops:read-from-file surveys-db-file))
(new-value (list uid post-params)))
(new-entry (survey-to-plist new-survey)))
(ml-survey/fileops:write-to-file surveys-db-file
(push new-value stored-surveys))
(view uid)))
(push new-entry stored-surveys))
(view (survey-uid new-survey))))
(defun process-request (request)
(ecase (hunchentoot:request-method*)

1
src/fileops.lisp
View file

@ -101,6 +101,7 @@ within the data directory."
(defun write-to-file (db responses)
(check-type db (or string pathname))
(check-type responses list)
(ensure-directories-exist db)
(with-open-file (stream db
:direction :output
:if-exists :supersede)

5
src/models/package.lisp
View file

@ -2,6 +2,9 @@
(defpackage :ml-survey/models
(:use #:cl)
(:export #:object-to-plist
#:make-survey
#:survey-to-plist
#:plist-to-survey
#:survey-uid
#:survey-uid-p
#:survey
@ -13,10 +16,10 @@
#:survey-properties-description
#:survey-html
#:survey-questionnaires
#:filter-surveys-by-uid
#:questionnaire
#:questionnaire-uid
#:questionnaire-name
#:questionnaire-type
#:questionnaire-lang
#:questionnaire-timestamp-created
#:questionnaire-post-params

35
src/models/questionnaire.lisp
View file

@ -5,40 +5,47 @@
(defclass questionnaire ()
((uid :initarg :uid
:reader questionnaire-uid
:type integer
:initform (ml-survey/app:generate-uuid)
:documentation "Unique identifier for this questionnaire instance (auto-generated).")
(name :initarg :name
:reader questionnaire-name
:type string
:initform "sus"
:documentation "The display name of the questionnaire.")
(type :initarg :type
:reader questionnaire-type
:documentation "The questionnaire type. (e.g. likert, mixed)")
(lang :initarg :lang
:reader questionnaire-lang
:type string
:initform "en"
:documentation "Language code for the questionnaire.")
(data-file :initarg :data-file
:accessor questionnaire-data-file
:type pathname
:initform (ml-survey/fileops:ensure-surveys-dir)
:documentation "Location of data file as pathname.")
(survey-uid :initarg :survey-uid
:reader questionnaire-survey-uid
:type integer
:initform 0
:documentation "Unique identifier for the survey.")
(post-params :initarg :post-params
:accessor questionnaire-post-params
:documentation "Additional parameters for post-processing.")
(timestamp-created :initarg :timestamp-created
:reader questionnaire-timestamp-created
:initform (ml-survey/app:today+now)
:documentation "Creation/modification time (auto-generated).")))
(defmethod initialize-instance :after ((q questionnaire) &key)
(with-slots (timestamp-created uid data-file survey-uid) q
(or timestamp-created
(setf timestamp-created (ml-survey/app:today+now)))
(or uid
(setf uid (ml-survey/app:generate-uuid)))
(or data-file
(setf data-file (pathname (format nil "~a~a/~a.lisp"
(ml-survey/fileops:ensure-surveys-dir)
survey-uid
uid))))))
(with-slots (uid data-file survey-uid) q
(let ((uid-str (format nil "~a" uid))
(data-file-str (format nil "~a" data-file)))
(unless (search uid-str data-file-str)
(setf data-file
(pathname (format nil "~a~a/~a.lisp"
(ml-survey/fileops:ensure-surveys-dir)
survey-uid
uid)))))))
(defmethod make-questionnaire (&rest initargs &key &allow-other-keys)
"Create a new questionnaire instance.
@ -51,4 +58,4 @@ Accepts all valid initargs for questionnaire class."
(defmethod questionnaire-write-file ((q questionnaire))
(ml-survey/fileops:write-to-file (questionnaire-data-file q)
(questionnaire-to-list q)))
(questionnaire-to-plist q)))

47
src/models/survey.lisp
View file

@ -1,31 +1,35 @@
;;; -*- mode: lisp; coding: utf-8; -*-
(in-package :ml-survey/models)
(defclass survey ()
((uid :initarg :uid
:reader survey-uid
:type integer
:initform (ml-survey/app:generate-uuid)
:documentation "Unique ID.")
(data-dir :initarg :data-dir
:reader survey-data-dir
:type pathname
:initform (ml-survey/fileops:ensure-surveys-dir)
:documentation "The directory where questionnaires are saved.")
(properties :initarg :properties
:reader survey-properties
:accessor survey-properties
:type list
:initform '(("title" . "")
("description" . "")
("questionnaire" . ""))
:documentation "Properties as title and description."))
(:documentation "Represents a survey."))
(defmethod initialize-instance :after ((survey survey) &key)
(with-slots (uid data-dir properties) survey
(or (if (integerp uid)
uid
(setf uid (parse-integer uid)))
(setf uid (ml-survey/app:generate-uuid)))
(or data-dir
(with-slots (uid data-dir) survey
(let ((uid-str (format nil "~a/" uid))
(data-dir-str (format nil "~a" data-dir)))
(unless (search uid-str data-dir-str)
(setf data-dir
(uiop:merge-pathnames* (format nil "~a/" uid)
(ml-survey/fileops:ensure-surveys-dir))))))
(uiop:merge-pathnames* uid-str
(ml-survey/fileops:ensure-surveys-dir)))))))
(defgeneric survey-id-p (survey)
(:documentation "Check if the survey ID is present in the surveys database."))
@ -43,8 +47,12 @@
(:documentation "Get description property."))
(defmethod survey-uid-p ((survey survey))
(let ((ids (mapcar #'first (ml-survey/fileops:surveys-db))))
(if (member (survey-id survey)) ids) t nil))
(if (remove-if-not (lambda (s)
(eql (getf s :uid)
(survey-uid survey)))
(ml-survey/fileops:surveys-db))
t
nil))
(defmethod survey-data-dir-files ((survey survey))
(uiop:directory-files (survey-data-dir survey)))
@ -72,9 +80,22 @@ MAKE-FN: Function which is applied to the questionnaire data structure. Can be u
(defmethod survey-to-plist ((survey survey))
(object-to-plist survey))
(defun build-questionnaire-link (survey-id resource)
(defun make-survey (&rest initargs &key &allow-other-keys)
"Create a new survey instance.
Accepts all valid initargs for survey class."
(apply #'make-instance 'survey initargs))
(defun build-questionnaire-link (survey-uid resource)
(format nil "/questionnaire/~a~a" survey-uid resource))
(defun plist-to-survey (survey-plist)
(apply #'make-instance 'survey survey-plist))
(defun filter-surveys-by-uid (survey-uid)
(remove-if-not (lambda (s)
(eql (getf s :uid) survey-uid))
(ml-survey/fileops:surveys-db)))
(defmethod survey-html ((survey survey))
(spinneret:with-html
(:dl (loop for property in (survey-properties survey)
@ -83,5 +104,5 @@ MAKE-FN: Function which is applied to the questionnaire data structure. Can be u
(:dt key)
(cond ((string= key "questionnaire")
(:dd (:a :href (build-questionnaire-link (survey-uid survey) value)
(format nil "Open Questionnaire ~a" value))))
(format nil "Open Questionnaire ~a" value))))
(t (:dd value)))))))

5
src/questionnaire/handler.lisp
View file

@ -33,10 +33,7 @@
(define-easy-handler (questionnaire-handler :uri #'questionnaire-uri) ()
(let* ((survey-uid (parse-integer (extract-uri-param :survey-id)))
(questionnaire (make-questionnaire :timestamp-created nil
:uid nil
:data-file nil
:survey-uid survey-uid
(questionnaire (make-questionnaire :survey-uid survey-uid
:lang (extract-uri-param :lang)
:name (extract-uri-param :questionnaire))))
(process-request questionnaire)))

6
src/survey/handler.lisp
View file

@ -12,9 +12,9 @@
(survey-uri-p (hunchentoot:request-uri request)))
(define-easy-handler (survey-handler :uri #'survey-uri) ()
(let* ((survey-uid (ml-survey/app:extract-from (hunchentoot:request-uri*)
:survey-id))
(s (make-instance 'survey :id survey-uid))
(let* ((survey-uid (parse-integer (ml-survey/app:extract-from (hunchentoot:request-uri*)
:survey-id)))
(s (plist-to-survey (first (filter-surveys-by-uid survey-uid))))
(questionnaires (survey-questionnaires s))
(assessments (parse-questionnaires questionnaires)))
(view s assessments)))

4
src/survey/view.lisp
View file

@ -11,9 +11,9 @@
(with-body-main "fluid"
(:div :class "row"
(with-section-props (with-title-bar "Properties")
(:p (format nil "ID: ~a" (survey-id survey)))
(:p (format nil "ID: ~a" (survey-uid 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)))))))))
do (assessment-html assessment (survey-uid survey)))))))))

3
src/surveys/handler.lisp
View file

@ -3,8 +3,7 @@
(defun list-of-surveys ()
(mapcar (lambda (x)
(make-instance 'survey
:id (first x)))
(plist-to-survey x))
(ml-survey/fileops:surveys-db)))
(define-easy-handler (surveys-handler :uri "/") nil

2
src/surveys/view.lisp
View file

@ -28,7 +28,7 @@ SURVEYS: List of survey objects."
(let* ((title (survey-properties-title survey))
(description (survey-properties-description survey))
(description-empty (string= description ""))
(id (survey-id survey))
(id (survey-uid survey))
(url (format nil "/surveys/~a" id)))
(with-card*
:card-header