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, 316 insertions, 61 deletions
diff --git a/lisp/service/about-us-service.lisp b/lisp/service/about-us-service.lisp
index 1ede1d2..33e95a6 100644
--- a/lisp/service/about-us-service.lisp
+++ b/lisp/service/about-us-service.lisp
@@ -9,8 +9,10 @@
:accessor category))
(:documentation ""))
-(defun about-us-json (category)
+(defun about-us-json (category &optional message errormsg)
(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)
@@ -51,7 +53,7 @@
(setf (form instance) (make-form "about-us-modify-form"
nil
nil
- `((:label "Content" :name "txt-content" :field-type "textarea" :value ,(content about-us) :required "required")
+ `((:label "Content" :name "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)
@@ -64,3 +66,16 @@
(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 ecd9469..760e2b9 100644
--- a/lisp/service/base-service.lisp
+++ b/lisp/service/base-service.lisp
@@ -3,15 +3,192 @@
(in-package :bogenherr)
-(defclass base-service ()
- ()
+;; 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))
(: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))))
@@ -19,3 +196,28 @@
(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 4e2aada..eea7f49 100644
--- a/lisp/service/contact-us-service.lisp
+++ b/lisp/service/contact-us-service.lisp
@@ -82,3 +82,7 @@
(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 c3d0825..d20339b 100644
--- a/lisp/service/gallery-service.lisp
+++ b/lisp/service/gallery-service.lisp
@@ -134,3 +134,12 @@
(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
deleted file mode 100644
index 592d245..0000000
--- a/lisp/service/generics.lisp
+++ /dev/null
@@ -1,15 +0,0 @@
-;;; -*- 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 da6ded6..30e5a03 100644
--- a/lisp/service/home-service.lisp
+++ b/lisp/service/home-service.lisp
@@ -16,3 +16,6 @@
(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 7a80bfd..dfe245c 100644
--- a/lisp/service/login-service.lisp
+++ b/lisp/service/login-service.lisp
@@ -62,3 +62,8 @@
(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 90b513a..44b9020 100644
--- a/lisp/service/menu-service.lisp
+++ b/lisp/service/menu-service.lisp
@@ -96,3 +96,6 @@
(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 e03c04c..c40113c 100644
--- a/lisp/service/messages-service.lisp
+++ b/lisp/service/messages-service.lisp
@@ -55,3 +55,7 @@
(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 32507d2..de9878a 100644
--- a/lisp/service/password-service.lisp
+++ b/lisp/service/password-service.lisp
@@ -48,3 +48,6 @@
(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 256d599..d14e3c7 100644
--- a/lisp/service/profile-service.lisp
+++ b/lisp/service/profile-service.lisp
@@ -59,3 +59,8 @@
(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 b01f7fa..4be2ce4 100644
--- a/lisp/service/rest-service.lisp
+++ b/lisp/service/rest-service.lisp
@@ -39,3 +39,5 @@
(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 97133f7..bdd3a7d 100644
--- a/lisp/service/testimonials-service.lisp
+++ b/lisp/service/testimonials-service.lisp
@@ -67,3 +67,8 @@
(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 5b16d46..a2b29d4 100644
--- a/lisp/service/users-service.lisp
+++ b/lisp/service/users-service.lisp
@@ -35,7 +35,7 @@
:accessor form))
(:documentation ""))
-(defun role-checkboxes (role-groups &optional active-role-groups)
+(defun role-checkboxes (name 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" (name role-group)) :label ,(name role-group) :field-type "checkbox" ,@checked)))))
+ (remove-if 'null `(:name ,(format nil "chk_~a_~a" name (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 role-groups)
+ ,@(role-checkboxes "users_add" 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?hash=~a"
+ "~a://~a/register/~a"
(scheme *webapp*)
(url *webapp*)
(hash registration)))
,(format nil
- "~a://~a/register?hash=~a"
+ "~a://~a/register/~a"
(scheme *webapp*)
(url *webapp*)
(hash registration))))))))
@@ -145,18 +145,16 @@
(registration (get-registration-by-hash auth-pkg hash)))
(registrations-gc auth-pkg)
(if registration
- (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 (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 :errormsg) "Error: invalid registration."))))))
(defclass users/register/submit-service (rest-service)
@@ -170,30 +168,29 @@
registration)
(registrations-gc auth-pkg)
(setf registration (get-registration-by-hash auth-pkg hash))
- (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."))))))))
+ (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)
()
@@ -218,7 +215,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 role-groups active-role-groups)
+ ,@(role-checkboxes "users_modify" 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."))))))
@@ -280,3 +277,16 @@
(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 15:32:17 +0000