summaryrefslogtreecommitdiff
path: root/lisp/service
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/service')
-rw-r--r--lisp/service/about-us-service.lisp19
-rw-r--r--lisp/service/base-service.lisp206
-rw-r--r--lisp/service/contact-us-service.lisp4
-rw-r--r--lisp/service/gallery-service.lisp9
-rw-r--r--lisp/service/generics.lisp15
-rw-r--r--lisp/service/home-service.lisp3
-rw-r--r--lisp/service/login-service.lisp5
-rw-r--r--lisp/service/menu-service.lisp3
-rw-r--r--lisp/service/messages-service.lisp4
-rw-r--r--lisp/service/password-service.lisp3
-rw-r--r--lisp/service/profile-service.lisp5
-rw-r--r--lisp/service/rest-service.lisp2
-rw-r--r--lisp/service/testimonials-service.lisp5
-rw-r--r--lisp/service/users-service.lisp94
14 files changed, 61 insertions, 316 deletions
diff --git a/lisp/service/about-us-service.lisp b/lisp/service/about-us-service.lisp
index 33e95a6..1ede1d2 100644
--- a/lisp/service/about-us-service.lisp
+++ b/lisp/service/about-us-service.lisp
@@ -9,10 +9,8 @@
:accessor category))
(:documentation ""))
-(defun about-us-json (category &optional message errormsg)
+(defun about-us-json (category)
(with-noauth (instance about-us-service)
- (when (not (org-ckons-core::null-or-empty-p message)) (setf (message instance) message))
- (when (not (org-ckons-core::null-or-empty-p errormsg)) (setf (errormsg instance) errormsg))
(setf (category instance) category)))
(defclass about-us/view-service (about-us-service)
@@ -53,7 +51,7 @@
(setf (form instance) (make-form "about-us-modify-form"
nil
nil
- `((:label "Content" :name "content" :field-type "textarea" :value ,(content about-us) :required "required")
+ `((:label "Content" :name "txt-content" :field-type "textarea" :value ,(content about-us) :required "required")
(:label "Modify" :field-type "button" :onclick "on_about_us_modify_submit_clicked()"))))))))
(defun about-us-modify-submit-json (category content)
@@ -66,16 +64,3 @@
(update-record general-pkg about-us))))
(setf (content instance) content)
(setf (message instance) "About Us text saved successfully.")))
-
-(define-endpoint ("/lessons" :method :get) () about-us-json "lessons")
-(define-endpoint ("/lessons/view" :method :get) () about-us-view-json "lessons")
-(define-endpoint ("/lessons/modify" :method :post) () about-us-modify-json "lessons")
-(define-endpoint ("/lessons/modify/submit" :method :post) (&post (content :parameter-type 'string)) about-us-modify-submit-json "lessons" content)
-(define-endpoint ("/gigs" :method :get) () about-us-json "gigs")
-(define-endpoint ("/gigs/view" :method :get) () about-us-view-json "gigs")
-(define-endpoint ("/gigs/modify" :method :post) () about-us-modify-json "gigs")
-(define-endpoint ("/gigs/modify/submit" :method :post) (&post (content :parameter-type 'string)) about-us-modify-submit-json "gigs" content)
-(define-endpoint ("/programming" :method :get) () about-us-json "programming")
-(define-endpoint ("/programming/view" :method :get) () about-us-view-json "programming")
-(define-endpoint ("/programming/modify" :method :post) () about-us-modify-json "programming")
-(define-endpoint ("/programming/modify/submit" :method :post) (&post (content :parameter-type 'string)) about-us-modify-submit-json "programming" content)
diff --git a/lisp/service/base-service.lisp b/lisp/service/base-service.lisp
index 760e2b9..ecd9469 100644
--- a/lisp/service/base-service.lisp
+++ b/lisp/service/base-service.lisp
@@ -3,192 +3,15 @@
(in-package :bogenherr)
-;; webapp
-
-(defvar *acceptor* nil)
-(defvar *dispatch-table* '(#'dispatch-easy-handlers #'default-dispatcher))
-(defvar *webapps* (make-hash-table :test 'equal))
-(defvar *webapp* nil)
-(defvar *uri* nil)
-(defvar *header-register* nil)
-(defvar *sessionid* nil)
-(defparameter *port* 3012)
-(defparameter *server-root* (namestring (asdf:system-relative-pathname (intern (package-name #.*package*)) "./"))
- "The location of the web server root on the filesystem.")
-
-(defclass webapp ()
- ((name :initarg :name
- :initform nil
- :accessor name
- :documentation "The name of the webapp as used in the code. A
-string used as the key to any webapp config lookup.")
- (scheme :initarg :scheme
- :initform nil
- :accessor scheme)
- (url :initarg :url
- :initform nil
- :accessor url
- :documentation "The domain portion of the URL to the
-root of the webapp.")
- (document-root :initarg :document-root
- :initform nil
- :accessor document-root
- :documentation "The absolute filesystem path to the
-webapp's top-level directory which is inside the webapps folder.")
- (title :initarg :title
- :initform nil
- :accessor title
- :documentation "The default title that shows up in
-the browser title bar.")
- (meta-description :initarg :meta-description
- :initform nil
- :accessor meta-description
- :documentation "The text that goes into the META DESCRIPTION
-tag, and anywhere else we want to put this text so that it will show
-up in Google.")
- (databases :initarg :databases
- :initform nil
- :accessor databases)
- (mail-mx :initarg :mail-mx
- :initform nil
- :accessor mail-mx)
- (mail-from :initarg :mail-from
- :initform nil
- :accessor mail-from)
- (mail-postmaster :initarg :mail-postmaster
- :initform nil
- :accessor mail-postmaster)
- (mail-webmaster :initarg :mail-webmaster
- :initform nil
- :accessor mail-webmaster)
- (mail-info :initarg :mail-info
- :initform nil
- :accessor mail-info)
- (mail-login-notify :initarg :mail-login-notify
- :initform nil
- :accessor mail-login-notify)
- (mail-authentication :initarg :mail-authentication
- :initform nil
- :accessor mail-authentication)
- (mail-ssl :initarg :mail-ssl
- :initform nil
- :accessor mail-ssl))
+(defclass base-service ()
+ ()
(:documentation ""))
-(defmethod get-site-file-path ((webapp webapp))
- (format nil "~a/site" (document-root webapp)))
-
-(defmethod get-pages-file-paths ((webapp webapp))
- (mapcar (lambda (pages-file)
- (ppcre:regex-replace-all "\\.lisp$" (format nil "~a" pages-file) ""))
- (remove-if (lambda (x) (equal x "shared"))
- (org-ckons-core::shell-wrapper (format nil "find '~a' -maxdepth 1 -type f -iname 'pages*.lisp' |sort" (document-root webapp))))))
-
-(defun make-server-path (relative-path)
- "Makes a relative filesystem path into a full one, using
-`*server-root*' as the base."
- (make-document-root-path *server-root* relative-path))
-
-(defun make-document-root-path (document-root relative-path)
- "Makes a relative filesystem path into a full one, using
-`document-root' as the base."
- (concatenate 'string document-root relative-path))
-
-(defun make-webapp-path (relative-path)
- "Makes an absolute filesystem path to a location in the webapps
-folder."
- (concatenate 'string *server-root* "webapps/" relative-path))
-
-(defun get-options-files ()
- (mapcar (lambda (webapp-directory)
- (format nil "~a/conf/options.lisp" webapp-directory))
- (remove-if (lambda (x) (or (org-ckons-core::match-it "webapps/$" x)
- (org-ckons-core::match-it "webapps/shared$" x)
- (org-ckons-core::match-it "webapps/CVS$" x)
- (org-ckons-core::match-it "webapps/\\.$" x)
- (org-ckons-core::match-it "webapps/\\.\\.$" x)))
- (org-ckons-core::shell-wrapper (format nil "find '~a' -maxdepth 1 -type d |sort" (make-webapp-path ""))))))
-
-(defun set-webapp (webapp)
- "Sets a `webapp' object in `*webapps*'. The lookup key is the webapp
-name. If a webapp already exists under this key, it gets overwritten
-with the new one."
- (setf (gethash (name webapp) *webapps*) webapp))
-
-(defun get-webapp (key)
- "Gets the webapp object stored under the key `key'."
- (gethash key *webapps*))
-
-(defun populate-webapps ()
- (loop for options-file in (get-options-files)
- do (with-open-file (input options-file :direction :input)
- (let* ((form (read input)))
- (set-webapp (make-instance 'webapp
- :name (getf form :name)
- :scheme (getf form :scheme)
- :url (getf form :url)
- :document-root (make-webapp-path (getf form :document-root))
- :title (getf form :title)
- :meta-description (getf form :meta-description)
- :databases (getf form :databases)
- :mail-mx (getf form :mail-mx)
- :mail-from (getf form :mail-from)
- :mail-postmaster (getf form :mail-postmaster)
- :mail-webmaster (getf form :mail-webmaster)
- :mail-info (getf form :mail-info)
- :mail-login-notify (getf form :mail-login-notify)
- :mail-authentication (getf form :mail-authentication)
- :mail-ssl (getf form :mail-ssl)))))))
-
-(defun bogenherr ()
- "Call this to start the server."
- (when (null *acceptor*)
- (let ((package (string-downcase (package-name #.*package*))))
- (populate-webapps)
- (setf (log-manager) (make-instance 'log-manager :message-class 'formatted-message))
- (start-messenger 'text-file-messenger :filename (format nil "/var/log/lisp/~a.log" package))
- (setf *session-secret* (org-ckons-session::generate-sessionid))
- (populate-webapps)
- (setf *acceptor* (start (make-instance 'easy-routes:easy-routes-acceptor
- :port *port*
- :document-root (make-server-path (format nil "webapps/~a/" package))
- :name (format nil "~a-acceptor" package)))))))
-
-(defmacro with-request-wrapper (uri page-function &rest args)
- (let ((package (string-downcase (package-name #.*package*))))
- `(let (output)
- (let* ((*webapp* (get-webapp ,package))
- (*uri* ,uri)
- (*header-register* (make-instance 'org-ckons-session::header-register))
- (*sessionid* (ensure-user-session-exists)))
- (ensure-user-exists)
- (setf output (,page-function ,@args))
- (org-ckons-session::ship-headers *header-register*))
- output)))
-
-(defmacro define-endpoint (template-and-options var-list page-function &rest args)
- "Does the grunt work of creating an `easy-routes' route for each page
-you wish to publish."
- (let ((name (gensym))
- (uri (first template-and-options))
- (method (getf (rest template-and-options) :method)))
- `(progn
- (org-ckons-core::logger (format nil "Publishing page. URL = [~a], method = [~a]" ,uri ,method))
- (easy-routes:defroute ,name ,template-and-options
- ,var-list
- (with-request-wrapper ,uri ,page-function ,@args)))))
-
-;; base-service
-
(defmacro loop-intersect-slots ((slot record other-object) &body body)
`(loop for ,slot in (intersect-slots ,record (org-ckons-core::map-slot-names ,other-object))
do (when (slot-is-field-p ,slot)
,@body)))
-(defclass base-service ()
- ()
- (:documentation ""))
-
(defmethod copy-from-record ((base-service base-service) (record record))
(loop-intersect-slots (slot record base-service)
(setf (slot-value base-service slot) (slot-value record slot))))
@@ -196,28 +19,3 @@ you wish to publish."
(defmethod copy-to-record ((base-service base-service) (record record))
(loop-intersect-slots (slot record base-service)
(setf (slot-value record slot) (slot-value base-service slot))))
-
-(defun base (&optional (start-url "/home"))
- (org-ckons-http::html5
- `(html
- (head
- ((meta :name "viewport" :content "width=device-width, initial-scale=1, shrink-to-fit=no"))
- ((meta :charset "utf-8"))
- ((title) ,(title *webapp*))
- ,@(mapcar (lambda (css)
- `((link :rel "stylesheet" :href ,(getf css :href) :integrity ,(getf css :integrity) :crossorigin ,(getf css :crossorigin))))
- '((:href "https://cdn.jsdelivr.net/npm/bootstrap@4.6.2/dist/css/bootstrap.min.css" :integrity "sha384-xOolHFLEh07PJGoPkLv1IbcEPTNtaed2xpHsD9ESMhqIYd0nLMwNLD69Npy4HI+N" :crossorigin "anonymous")
- (:href "/static/css/stylesheet.css" :crossorigin "anonymous")))
- ,@(mapcar (lambda (js)
- `((script :type "text/javascript" :src ,(getf js :src) :integrity ,(getf js :integrity) :crossorigin ,(getf js :crossorigin))))
- '((:src "https://code.jquery.com/jquery-3.7.1.slim.min.js" :integrity "sha256-kmHvs0B+OpCW5GVHUNjv9rOmY0IvSIRcf7zGUDTDQM8=" :crossorigin "anonymous")))
- ((script :type "text/javascript" :src "/cljs-out/dev-main.js")))
- ((body :onload ,(format nil "bogenherr.core.start(~a)" (if start-url
- (format nil "'~a'" start-url)
- "null")))
- ((div :id "app"))
- ,@(mapcar (lambda (js)
- `((script :type "text/javascript" :src ,(getf js :src) :integrity ,(getf js :integrity) :crossorigin ,(getf js :crossorigin))))
- '((:src "https://cdn.jsdelivr.net/npm/bootstrap@4.6.2/dist/js/bootstrap.bundle.min.js" :integrity "sha384-Fy6S3B9q64WdZWQUiU+q4/2Lc9npb8tCaSX9FK7E8HnRr0Jz8D6OP9dO5Vg3Q9ct" :crossorigin "anonymous")))))))
-
-(define-endpoint ("/" :method :get) () base)
diff --git a/lisp/service/contact-us-service.lisp b/lisp/service/contact-us-service.lisp
index eea7f49..4e2aada 100644
--- a/lisp/service/contact-us-service.lisp
+++ b/lisp/service/contact-us-service.lisp
@@ -82,7 +82,3 @@
(error (e)
(declare (ignore e))
(setf (session-value :errormsg) "Error submitting form.")))))))
-
-(define-endpoint ("/contact-us" :method :get) () contact-us-json)
-(define-endpoint ("/contact-us/view" :method :get) () contact-us-view-json)
-(define-endpoint ("/contact-us/email" :method :post) (&post (first_name :parameter-type 'string) (last_name :parameter-type 'string) (email :parameter-type 'string) (phone :parameter-type 'string) (comments :parameter-type 'string)) contact-us-email-json first_name last_name email phone comments)
diff --git a/lisp/service/gallery-service.lisp b/lisp/service/gallery-service.lisp
index d20339b..c3d0825 100644
--- a/lisp/service/gallery-service.lisp
+++ b/lisp/service/gallery-service.lisp
@@ -134,12 +134,3 @@
(when gallery
(setf (org-ckons-session::content-type *header-register*) (mime_type gallery))
(ironclad:hex-string-to-byte-array (content gallery)))))))
-
-(define-endpoint ("/gallery" :method :get) () gallery-json)
-(define-endpoint ("/gallery/view" :method :get) () gallery-view-json)
-(define-endpoint ("/gallery/add" :method :post) () gallery-add-json)
-(define-endpoint ("/gallery/add/submit" :method :post) (&post (description :parameter-type 'string) (video_embed_url :parameter-type 'string) (upload :parameter-type 'string)) gallery-add-submit-json description video_embed_url upload)
-(define-endpoint ("/gallery/modify" :method :post) (&post (id :parameter-type 'integer)) gallery-modify-json id)
-(define-endpoint ("/gallery/modify/submit" :method :post) (&post (id :parameter-type 'integer) (description :parameter-type 'string) (video_embed_url :parameter-type 'string) (upload :parameter-type 'string)) gallery-modify-submit-json id description video_embed_url upload)
-(define-endpoint ("/gallery/delete/:id" :method :delete) (&path (id 'integer)) gallery-delete-json id)
-(define-endpoint ("/gallery/file/view/:id" :method :get) (&path (id 'integer)) gallery-file-view-json id)
diff --git a/lisp/service/generics.lisp b/lisp/service/generics.lisp
new file mode 100644
index 0000000..592d245
--- /dev/null
+++ b/lisp/service/generics.lisp
@@ -0,0 +1,15 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :bogenherr)
+
+(defgeneric copy-from-record (base-service record)
+ (:documentation "Copies the fields from `record' to
+`base-service'."))
+
+(defgeneric copy-to-record (base-service record)
+ (:documentation "Copies the fields from `base-service' to
+`record'."))
+
+(defgeneric sanitize-rest-json (rest-service)
+ (:documentation ""))
diff --git a/lisp/service/home-service.lisp b/lisp/service/home-service.lisp
index 30e5a03..da6ded6 100644
--- a/lisp/service/home-service.lisp
+++ b/lisp/service/home-service.lisp
@@ -16,6 +16,3 @@
(with-noauth (instance home-service)
(when (not (org-ckons-core::null-or-empty-p message)) (setf (message instance) message))
(when (not (org-ckons-core::null-or-empty-p errormsg)) (setf (errormsg instance) errormsg))))
-
-(define-endpoint ("/home" :method :get) () home-json)
-(define-endpoint ("/home" :method :post) (&post (message :parameter-type 'string) (errormsg :parameter-type 'string)) home-json message errormsg)
diff --git a/lisp/service/login-service.lisp b/lisp/service/login-service.lisp
index dfe245c..7a80bfd 100644
--- a/lisp/service/login-service.lisp
+++ b/lisp/service/login-service.lisp
@@ -62,8 +62,3 @@
(setf (session-value :errormsg) "Login failed."))))))
(setf (message instance) (session-value :message))
(setf (errormsg instance) (session-value :errormsg))))
-
-(define-endpoint ("/login" :method :get) () login-json)
-(define-endpoint ("/login/authenticate" :method :post) (&post (username :parameter-type 'string) (pwd :parameter-type 'string)) login-authenticate-json username pwd)
-(define-endpoint ("/login/forgot" :method :get) () login-forgot-json)
-(define-endpoint ("/logout" :method :get) () logout-json)
diff --git a/lisp/service/menu-service.lisp b/lisp/service/menu-service.lisp
index 44b9020..90b513a 100644
--- a/lisp/service/menu-service.lisp
+++ b/lisp/service/menu-service.lisp
@@ -96,6 +96,3 @@
(format nil "~a ~a" (first_name user) (last_name user))
"No User Found"))
(org-ckons-json::objects-to-json `(,instance))))
-
-(define-endpoint ("/menu" :method :get) () menu-json)
-(define-endpoint ("/menu/user" :method :get) () menu-user-json)
diff --git a/lisp/service/messages-service.lisp b/lisp/service/messages-service.lisp
index c40113c..e03c04c 100644
--- a/lisp/service/messages-service.lisp
+++ b/lisp/service/messages-service.lisp
@@ -55,7 +55,3 @@
(error (e)
(declare (ignore e))
(setf (session-value :errormsg) (format nil "Error marking message ~a." read)))))))
-
-(define-endpoint ("/messages" :method :get) () messages-json)
-(define-endpoint ("/messages/results" :method :post) (&post (read :parameter-type 'string)) messages-results-json read)
-(define-endpoint ("/messages/mark" :method :post) (&post (read :parameter-type 'string) (id :parameter-type 'integer)) messages-mark-json read id)
diff --git a/lisp/service/password-service.lisp b/lisp/service/password-service.lisp
index de9878a..32507d2 100644
--- a/lisp/service/password-service.lisp
+++ b/lisp/service/password-service.lisp
@@ -48,6 +48,3 @@
(set-user user)
(setf (session-value :message) "Password saved successfully."))
(setf (session-value :errormsg) "An error occured."))))))
-
-(define-endpoint ("/password" :method :get) () password-json)
-(define-endpoint ("/password/submit" :method :post) (&post (id :parameter-type 'integer) (pwd :parameter-type 'string) (pwd2 :parameter-type 'string)) password-submit-json id pwd pwd2)
diff --git a/lisp/service/profile-service.lisp b/lisp/service/profile-service.lisp
index d14e3c7..256d599 100644
--- a/lisp/service/profile-service.lisp
+++ b/lisp/service/profile-service.lisp
@@ -59,8 +59,3 @@
(set-user user)
(setf (session-value :message) "Profile saved successfully."))
(setf (session-value :errormsg) "An error occured."))))))
-
-(define-endpoint ("/profile" :method :get) () profile-json)
-(define-endpoint ("/profile/view" :method :get) () profile-view-json)
-(define-endpoint ("/profile/modify" :method :post) () profile-modify-json)
-(define-endpoint ("/profile/modify/submit" :method :post) (&post (id :parameter-type 'integer) (username :parameter-type 'string) (first_name :parameter-type 'string) (last_name :parameter-type 'string) (email :parameter-type 'string) (phone :parameter-type 'string)) profile-modify-submit-json id username first_name last_name email phone)
diff --git a/lisp/service/rest-service.lisp b/lisp/service/rest-service.lisp
index 4be2ce4..b01f7fa 100644
--- a/lisp/service/rest-service.lisp
+++ b/lisp/service/rest-service.lisp
@@ -39,5 +39,3 @@
(loop for slot in (intersection '(org-ckons-session::*session-key *table *where-expression pwd)
(org-ckons-core::map-slot-names rest-service))
do (setf (slot-value rest-service slot) nil)))
-
-(define-endpoint ("/location" :method :post) (&post (location :parameter-type 'string)) location-json location)
diff --git a/lisp/service/testimonials-service.lisp b/lisp/service/testimonials-service.lisp
index bdd3a7d..97133f7 100644
--- a/lisp/service/testimonials-service.lisp
+++ b/lisp/service/testimonials-service.lisp
@@ -67,8 +67,3 @@
(update-record general-pkg testimonials))))
(setf (content instance) content)
(setf (session-value :message) "Testimonials text saved successfully.")))
-
-(define-endpoint ("/testimonials" :method :get) () testimonials-json)
-(define-endpoint ("/testimonials/view" :method :get) () testimonials-view-json)
-(define-endpoint ("/testimonials/modify" :method :post) () testimonials-modify-json)
-(define-endpoint ("/testimonials/modify/submit" :method :post) (&post (content :parameter-type 'string)) testimonials-modify-submit-json content)
diff --git a/lisp/service/users-service.lisp b/lisp/service/users-service.lisp
index a2b29d4..5b16d46 100644
--- a/lisp/service/users-service.lisp
+++ b/lisp/service/users-service.lisp
@@ -35,7 +35,7 @@
:accessor form))
(:documentation ""))
-(defun role-checkboxes (name role-groups &optional active-role-groups)
+(defun role-checkboxes (role-groups &optional active-role-groups)
(remove-if 'null
(mapcar (lambda (role-group)
(when (not (intersection `(,(name role-group)) `("_Public" "profile-admin") :test 'string=))
@@ -45,7 +45,7 @@
active-role-groups)
:test 'string=)
'(:checked "checked" :value "on"))))
- (remove-if 'null `(:name ,(format nil "chk_~a_~a" name (name role-group)) :label ,(name role-group) :field-type "checkbox" ,@checked)))))
+ (remove-if 'null `(:name ,(format nil "chk_~a" (name role-group)) :label ,(name role-group) :field-type "checkbox" ,@checked)))))
role-groups)))
(defun users-add-json ()
@@ -61,7 +61,7 @@
`((:name "first_name" :label "First Name" :field-type "text" :required "required")
(:name "last_name" :label "Last Name" :field-type "text" :required "required")
(:name "email" :label "Email" :field-type "text" :required "required")
- ,@(role-checkboxes "users_add" role-groups)
+ ,@(role-checkboxes role-groups)
(:label "Add User" :field-type "button" :onclick "on_users_add_submit_clicked()"))))))))
(defun users-add-submit-json (role_groups first_name last_name email)
@@ -95,12 +95,12 @@
((p) "Please click the following link to complete the registration:")
((p)
((a :href ,(format nil
- "~a://~a/register/~a"
+ "~a://~a/register?hash=~a"
(scheme *webapp*)
(url *webapp*)
(hash registration)))
,(format nil
- "~a://~a/register/~a"
+ "~a://~a/register?hash=~a"
(scheme *webapp*)
(url *webapp*)
(hash registration))))))))
@@ -145,16 +145,18 @@
(registration (get-registration-by-hash auth-pkg hash)))
(registrations-gc auth-pkg)
(if registration
- (setf (form instance)
- (make-form "users-register-form"
- nil
- t
- `((:name "hash" :field-type "hidden" :value ,(hash registration) :required "required")
- (:name "username" :label "Username" :field-type "text" :required "required")
- (:name "pwd" :label "Password" :field-type "password" :required "required")
- (:name "pwd2" :label "Password (again)" :field-type "password" :required "required")
- (:name "phone" :label "Phone" :field-type "text")
- (:label "Register" :field-type "button" :onclick "on_users_register_submit_clicked()"))))
+ (progn
+ (setf (form instance)
+ (make-form "users-register-form"
+ nil
+ t
+ `((:name "hash" :field-type "hidden" :value ,(hash registration) :required "required")
+ (:name "username" :label "Username" :field-type "text" :required "required")
+ (:name "pwd" :label "Password" :field-type "password" :required "required")
+ (:name "pwd2" :label "Password (again)" :field-type "password" :required "required")
+ (:name "phone" :label "Phone" :field-type "text")
+ (:label "Register" :field-type "button" :onclick "on_users_register_submit_clicked()"))))
+ (setf (session-value :message) "Registered successfully."))
(setf (session-value :errormsg) "Error: invalid registration."))))))
(defclass users/register/submit-service (rest-service)
@@ -168,29 +170,30 @@
registration)
(registrations-gc auth-pkg)
(setf registration (get-registration-by-hash auth-pkg hash))
- (if registration
- (if (string= pwd pwd2)
- (let ((user (make-instance 'user
- :username username
- :pwd pwd
- :first_name (first_name registration)
- :last_name (last_name registration)
- :email (email registration)
- :phone phone
- :active t)))
- (if (insert-user auth-pkg user)
- (progn
- (loop for role-group in (union '("profile-admin")
- (cl-ppcre:split "\\|" (role_groups registration))
- :test 'string=)
- do (insert-user-role-group auth-pkg (make-instance 'user-role
- :user_id (id user)
- :role_group_name role-group)))
- (delete-registration auth-pkg hash)
- (setf (session-value :message) "Registration completed successfully."))
- (setf (session-value :errormsg) "Error while completing registration.")))
- (setf (session-value :errormsg) "Error: passwords do not match."))
- (setf (session-value :errormsg) "Error while completing registration."))))))
+ (org-ckons-json::objects-to-json
+ `(,(if registration
+ (if (string= pwd pwd2)
+ (let ((user (make-instance 'user
+ :username username
+ :pwd pwd
+ :first_name (first_name registration)
+ :last_name (last_name registration)
+ :email (email registration)
+ :phone phone
+ :active t)))
+ (if (insert-user auth-pkg user)
+ (progn
+ (loop for role-group in (union '("profile-admin")
+ (cl-ppcre:split "\\|" (role_groups registration))
+ :test 'string=)
+ do (insert-user-role-group auth-pkg (make-instance 'user-role
+ :user_id (id user)
+ :role_group_name role-group)))
+ (delete-registration auth-pkg hash)
+ (setf (session-value :message) "Registration completed successfully."))
+ (setf (session-value :errormsg) "Error while completing registration.")))
+ (setf (session-value :errormsg) "Error: passwords do not match."))
+ (setf (session-value :errormsg) "Error while completing registration."))))))))
(defclass users/modify-service (users/add-service)
()
@@ -215,7 +218,7 @@
(:name "last_name" :label "Last Name" :field-type "text" :value ,(last_name user) :required "required")
(:name "email" :label "Email" :field-type "text" :value ,(email user) :required "required")
(:name "phone" :label "Phone" :field-type "text" :value ,(phone user))
- ,@(role-checkboxes "users_modify" role-groups active-role-groups)
+ ,@(role-checkboxes role-groups active-role-groups)
(:label "Modify User" :field-type "button" :onclick "on_users_modify_submit_clicked()"))))
(setf (session-value :errormsg) "Error: could not modify user. Not found."))))))
@@ -277,16 +280,3 @@
(setf (session-value :errormsg) nil)
(setf (session-value :message) "User deleted successfully.")))
(setf (session-value :errormsg) "Error: could not delete user: not found."))))))
-
-(define-endpoint ("/users" :method :get) () users-json)
-(define-endpoint ("/users/view" :method :get) () users-view-json)
-(define-endpoint ("/users/add" :method :post) () users-add-json)
-(define-endpoint ("/users/add/submit" :method :post) (&post (role_groups :parameter-type 'string) (first_name :parameter-type 'string) (last_name :parameter-type 'string) (email :parameter-type 'string)) users-add-submit-json role_groups first_name last_name email)
-(define-endpoint ("/register" :method :get) (&get (hash :parameter-type 'string)) base (format nil "/register/~a" hash))
-(define-endpoint ("/users/register" :method :post) (&post (hash :parameter-type 'string)) users-register-json hash)
-(define-endpoint ("/users/register/form" :method :post) (&post (hash :parameter-type 'string)) users-register-form-json hash)
-(define-endpoint ("/users/register/submit" :method :post) (&post (hash :parameter-type 'string) (username :parameter-type 'string) (pwd :parameter-type 'string) (pwd2 :parameter-type 'string) (phone :parameter-type 'string)) users-register-submit-json hash username pwd pwd2 phone)
-(define-endpoint ("/users/modify" :method :post) (&post (id :parameter-type 'integer)) users-modify-json id)
-(define-endpoint ("/users/modify/submit" :method :post) (&post (id :parameter-type 'integer) (role_groups :parameter-type 'string) (username :parameter-type 'string) (first_name :parameter-type 'string) (last_name :parameter-type 'string) (email :parameter-type 'string) (phone :parameter-type 'string)) users-modify-submit-json id role_groups username first_name last_name email phone)
-(define-endpoint ("/users/toggle-active" :method :post) (&post (id :parameter-type 'integer)) users-toggle-active-json id)
-(define-endpoint ("/users/delete/:id" :method :delete) (&path (id 'integer)) users-delete-json id)
generated by cgit v1.3 (git 2.53.0) at 2026-09-24 23:25:36 +0000