From 659fa037d5a9a886c602fcb82d47457b454008fd Mon Sep 17 00:00:00 2001
From: Marcus Kammer <marcus.kammer@mailbox.org>
Date: Fri, 28 Jun 2024 17:39:13 +0200
Subject: [PATCH] Work with qa url scheme based on forms file system

---
 src/handlers/main.lisp          | 16 ++++++++++------
 src/handlers/questionnaire.lisp | 14 ++++++++------
 src/package.lisp                |  1 +
 src/survey.lisp                 |  2 +-
 src/views/sus.lisp              | 13 ++++++-------
 5 files changed, 26 insertions(+), 20 deletions(-)

diff --git a/src/handlers/main.lisp b/src/handlers/main.lisp
index e36dd8c..ce8c392 100644
--- a/src/handlers/main.lisp
+++ b/src/handlers/main.lisp
@@ -1,16 +1,20 @@
 (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 get-resource-id (resource request)
-  (case resource
-    (survey (second (split-uri request)))))
-
-(defun get-survey-id (request)
-  (get-resource-id 'survey request))
+(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."
diff --git a/src/handlers/questionnaire.lisp b/src/handlers/questionnaire.lisp
index ae7559f..8da245e 100644
--- a/src/handlers/questionnaire.lisp
+++ b/src/handlers/questionnaire.lisp
@@ -1,20 +1,20 @@
 (in-package :ml-survey/handlers)
 
 (defun questionnaire-uri-p (uri)
-  "Check if the request URI matches the pattern '/survey/<numeric>/questionnaire/type'"
+  "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))
-         (string= (third parts) "questionnaire"))))
+         (= 2 (length (third parts))))))
 
 (defun questionnaire-uri (request)
   (questionnaire-uri-p (request-uri request)))
 
-(defun process-questionnaire-get (lang)
+(defun process-questionnaire-get (lang questionnaire)
   (check-type lang string)
   (setf ml-survey:*html-lang* lang)
-  (ml-survey/views:sus-form))
+  (ml-survey/views:sus-form questionnaire))
 
 (defun process-questionnaire-post (request survey)
   (let* ((post-params (post-parameters* request))
@@ -25,8 +25,10 @@
     (ml-survey/views:questionnaire-submit)))
 
 (define-easy-handler (questionnaire :uri #'questionnaire-uri) (lang)
-  (let ((s (make-instance 'ml-survey:survey :id (get-survey-id (request-uri*)))))
+  (let ((s (make-instance 'ml-survey:survey
+                          :id (extract-from (request-uri*) :survey-id))))
     (cond ((eq (hunchentoot:request-method*) :get)
-           (process-questionnaire-get lang))
+           (process-questionnaire-get (extract-from (request-uri*) :language)
+                                      (extract-from (request-uri*) :questionnaire)))
           ((eq (hunchentoot:request-method*) :post)
            (process-questionnaire-post *request* s)))))
diff --git a/src/package.lisp b/src/package.lisp
index de801ad..31c8eda 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -14,6 +14,7 @@
    #:survey-properties-description
    #:ensure-data-dir
    #:ensure-data-file-exist
+   #:ensure-forms-dir
    #:forms-dir
    #:forms-list-files
    #:extract-lang-and-filename
diff --git a/src/survey.lisp b/src/survey.lisp
index 25c5cef..7722209 100644
--- a/src/survey.lisp
+++ b/src/survey.lisp
@@ -48,7 +48,7 @@
   (cdr (assoc "description" (survey-properties survey) :test #'string-equal)))
 
 (defun build-questionnaire-link (survey-id resource)
-  (format nil "/survey/~a/questionnaire~a" survey-id resource))
+  (format nil "/survey/~a~a" survey-id resource))
 
 (defmethod survey-html ((survey survey))
   (spinneret:with-html
diff --git a/src/views/sus.lisp b/src/views/sus.lisp
index 603eca8..9137d46 100644
--- a/src/views/sus.lisp
+++ b/src/views/sus.lisp
@@ -1,12 +1,11 @@
 (in-package :ml-survey/views)
 
-(defun load-form (lang form-file-name)
+(defun load-form (lang questionnaire)
   "Load a Lisp file containing form definitions."
   (check-type lang string)
-  (check-type form-file-name string)
-  (let* ((relative-path (concatenate 'string "src/views/forms/" lang "/"))
-         (full-path (uiop:merge-pathnames* relative-path (uiop:getcwd)))
-         (form-path (uiop:merge-pathnames* form-file-name full-path)))
+  (check-type questionnaire string)
+  (let* ((full-path (uiop:merge-pathnames* (format nil "~a/~a.lisp" lang questionnaire)
+                                           (ml-survey:ensure-forms-dir))))
     (unless (probe-file form-path)
       (error "Form file ~A does not exist." form-path))
     (load form-path))
@@ -31,7 +30,7 @@ available in its environment for full functionality."
                   (btn-primary (:type "submit")
                     (find-l10n "submit" ml-survey:*html-lang* *l10n*))))))
 
-(defun sus-form ()
+(defun sus-form (questionnaire)
   (with-page (:title "SUS Form")
     (body-header "System Usability Form")
-    (with-form (load-form ml-survey:*html-lang* "sus.lisp"))))
+    (with-form (load-form ml-survey:*html-lang* questionnaire))))