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

Create surveys and get an overview of all surveys

Browse source
This commit is contained in:
Marcus Kammer 2024-05-30 22:06:13 +02:00
parent 5de2da8f8a
commit 89ae137c40
Signed by: marcuskammer
GPG key ID: C374817BE285268F
3 changed files with 111 additions and 40 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
package.lisp
View file

@ -40,4 +40,4 @@
(:use #:cl) (:use #:cl)
(:import-from #:dev.metalisp.sbt (:import-from #:dev.metalisp.sbt
#:with-page) #:with-page)
(:export #:index #:imprint #:new-survey)) (:export #:index #:imprint #:new-survey #:surveys #:create-survey #:survey))

55
src/main.lisp
View file

@ -57,9 +57,6 @@
((string= lang "de") (dev.metalisp.survey/forms:sus-form-de)) ((string= lang "de") (dev.metalisp.survey/forms:sus-form-de))
(t (error "Unsupported language: ~A" lang)))) (t (error "Unsupported language: ~A" lang))))
(define-easy-handler (index :uri "/") ()
(dev.metalisp.survey/pages:index))
(define-easy-handler (imprint :uri "/imprint") () (define-easy-handler (imprint :uri "/imprint") ()
(dev.metalisp.survey/pages:imprint)) (dev.metalisp.survey/pages:imprint))
@ -75,33 +72,47 @@
(store-response (make-db-path (today) "_submit-db.lisp") response) (store-response (make-db-path (today) "_submit-db.lisp") response)
(format nil "~A" response))) (format nil "~A" response)))
(defun starts-with-subseq (subseq seq) ;; (defun starts-with-subseq (subseq seq)
"Check if the sequence SEQ starts with the subsequence SUBSEQ." ;; "Check if the sequence SEQ starts with the subsequence SUBSEQ."
(let ((subseq-length (length subseq))) ;; (let ((subseq-length (length subseq)))
(and (<= subseq-length (length seq)) ;; (and (<= subseq-length (length seq))
(string= subseq (subseq seq 0 subseq-length))))) ;; (string= subseq (subseq seq 0 subseq-length)))))
(defun survey-uri-p (request) ;; (defun survey-uri-p (request)
"Predicate function to check if the request URI matches the survey pattern. ;; "Predicate function to check if the request URI matches the survey pattern.
The URI should start with \"/survey/\" followed by a numeric ID." ;; The URI should start with \"/survey/\" followed by a numeric ID."
;; (let* ((uri (hunchentoot:request-uri request))
;; (id (subseq uri (length "/survey/"))))
;; (and (starts-with-subseq "/survey/" uri)
;; (every #'digit-char-p id))))
(defun survey-uri-p (uri)
"Check if the request URI matches the pattern '/survey/<numeric>'"
(let ((parts (uiop:split-string uri :separator "/")))
(and (= (length parts) 3)
(string= (second parts) "survey")
(every #'digit-char-p (third parts)))))
(defun survey-uri (request)
(let ((uri (hunchentoot:request-uri request))) (let ((uri (hunchentoot:request-uri request)))
(and (starts-with-subseq "/survey/" uri) (survey-uri-p uri)))
(let ((id (subseq uri (length "/survey/"))))
(every #'digit-char-p id)))))
(define-easy-handler (survey-handler :uri #'survey-uri-p) () (define-easy-handler (survey :uri #'survey-uri) ()
(let ((id (subseq (hunchentoot:request-uri*) (length "/survey/")))) (let* ((id (subseq (hunchentoot:request-uri*) (length "/survey/")))
(setf (content-type*) "text/plain") (survey (assoc (parse-integer id) (load-response (make-surveys-db-path)))))
(format nil "Survey ID: ~a" id))) (dev.metalisp.survey/pages:survey survey)
(hunchentoot:request-uri*)))
(define-easy-handler (new-survey :uri "/new-survey") nil (define-easy-handler (new-survey :uri "/new-survey") nil
(dev.metalisp.survey/pages:new-survey)) (dev.metalisp.survey/pages:new-survey))
(define-easy-handler (create-survey :uri "/create-survey" (define-easy-handler (create-survey :uri "/create-survey") nil
:default-request-type :post) nil
(let ((post-params (post-parameters* *request*)) (let ((post-params (post-parameters* *request*))
(uid (* (get-universal-time) (random 999))) (uid (* (get-universal-time) (random 999)))
(stored-surveys (load-response (make-surveys-db-path)))) (stored-surveys (load-response (make-surveys-db-path))))
(store-response (make-surveys-db-path) (push (list uid post-params) stored-surveys)) (store-response (make-surveys-db-path) (push (list uid post-params) stored-surveys))
(setf (content-type*) "text/plain") (dev.metalisp.survey/pages:create-survey uid)))
(format nil "~A" post-params)))
(define-easy-handler (surveys :uri "/") nil
(let ((stored-surveys (load-response (make-surveys-db-path))))
(dev.metalisp.survey/pages:surveys stored-surveys)))

94
src/pages.lisp
View file

@ -8,11 +8,6 @@
(dev.metalisp.survey/partials:navbar-en) (dev.metalisp.survey/partials:navbar-en)
(:section :class "container" (:section :class "container"
(:h2 :class "mb-3" "Surveys") (:h2 :class "mb-3" "Surveys")
(:div :class "btn-toolbar my-3"
(:div :class "btn-group me-2"
(:a :class "btn btn-primary"
:href "/new-survey"
"New Survey")))
(loop for (lang anchors) on collection by #'cddr do (loop for (lang anchors) on collection by #'cddr do
(:section :class "container-fluid mb-3" (:section :class "container-fluid mb-3"
(:h3 :class "mb-3" lang) (:h3 :class "mb-3" lang)
@ -58,18 +53,20 @@
(:h3 "Questionnaires") (:h3 "Questionnaires")
(:div :class "mb-3" (:div :class "mb-3"
(let ((questionnaires '(("sus-de" "System Usability Scale (Deutsch)") (let ((questionnaires '(("sus?lang=de" "System Usability Scale (Deutsch)")
("sus-en" "System Usability Scale (English)")))) ("sus?lang=en" "System Usability Scale (English)"))))
(loop for el in questionnaires do (loop for el in questionnaires
(:div :class "form-check" for key = (first el)
(:input :class "form-check-input" for value = (second el) do
:type "checkbox" (:div :class "form-check"
:value "t" (:input :class "form-check-input"
:id (first el) :type "checkbox"
:name (first el) :value key
(:label :class "form-check-label" :id key
:for (first el) :name "questionnaire"
(second el))))))) (:label :class "form-check-label"
:for key
value))))))
(:button :type"Submit" (:button :type"Submit"
:class "btn btn-primary" :class "btn btn-primary"
@ -77,3 +74,66 @@
(defun imprint () (defun imprint ()
nil) nil)
(defun extract-title (list)
(cdr (assoc "title" (second list) :test #'string-equal)))
(defun extract-description (list)
(cdr (assoc "description" (second list) :test #'string-equal)))
(defun extract-id (list)
(first list))
(defun surveys (surveys)
"Generates the view to show all surveys available."
(with-page (:title "Surveys")
(dev.metalisp.survey/partials:navbar-en)
(:section :class "container"
(:h2 :class "mb-3" "Your Surveys")
(:div :class "btn-toolbar my-3"
(:div :class "btn-group me-2"
(:a :class "btn btn-primary"
:href "/new-survey"
"New Survey")))
(:ol :class "list-group list-group-numbered"
(loop for survey in surveys
for title = (extract-title survey)
for description = (extract-description survey)
for id = (extract-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"
:href (format nil "/survey/~A" id)
title)
(if description
(:span description)
nil))))))))
(defun create-survey (survey-id)
"Generates the view to show the survey created."
(with-page (:title "Surveys")
(dev.metalisp.survey/partials:navbar-en)
(:section :class "container"
(:h2 "Your Surveys")
(if survey-id
(:div :class "alert alert-info" :role "alert"
(format nil "Your new survey: ~A is created." survey-id))
nil))))
(defun survey (survey)
"Generates the view to show the survey created."
(let ((id (format nil "~a" (first survey)))
(properties (first (rest survey))))
(with-page (:title "Surveys")
(dev.metalisp.survey/partials:navbar-en)
(:section :class "container"
(:h2 id)
(:ul :class "list-group"
(loop for property in properties
for key = (car property)
for value = (cdr property) do
(:li :class "list-group-item"
(if (string= key "questionnaire")
(:a :href (concatenate 'string "/survey/" id "/" value)
value)
(format nil "~a: ~a" key value)))))))))