From e774d11af63764a7457d842ecd74b30a183fa71e Mon Sep 17 00:00:00 2001 From: ckonstanski Date: Sun, 6 Sep 2026 22:04:28 -0600 Subject: migrate to react --- lisp/service/about-us-service.lisp | 48 +++++--- lisp/service/base-service.lisp | 210 ++++++++++++++++++++++++++++++++++- lisp/service/contact-us-service.lisp | 34 +++--- lisp/service/gallery-service.lisp | 52 +++++---- lisp/service/generics.lisp | 15 --- lisp/service/home-service.lisp | 11 +- lisp/service/login-service.lisp | 61 +++++----- lisp/service/logout-service.lisp | 1 - lisp/service/menu-service.lisp | 3 + lisp/service/messages-service.lisp | 37 +++--- lisp/service/password-service.lisp | 21 ++-- lisp/service/profile-service.lisp | 42 ++++--- lisp/service/rest-service.lisp | 8 +- lisp/service/users-service.lisp | 204 +++++++++++++++++----------------- 14 files changed, 484 insertions(+), 263 deletions(-) delete mode 100644 lisp/service/generics.lisp (limited to 'lisp/service') diff --git a/lisp/service/about-us-service.lisp b/lisp/service/about-us-service.lisp index 1ede1d2..efc2d2f 100644 --- a/lisp/service/about-us-service.lisp +++ b/lisp/service/about-us-service.lisp @@ -9,10 +9,6 @@ :accessor category)) (:documentation "")) -(defun about-us-json (category) - (with-noauth (instance about-us-service) - (setf (category instance) category))) - (defclass about-us/view-service (about-us-service) ((content :initarg :content :initform nil @@ -23,26 +19,30 @@ (location :initform nil)) (:documentation "")) +(defclass about-us/modify-service (about-us/view-service auth-service) + ((form :initarg :form + :initform nil + :accessor form) + (admin-p :initform t) + (location-p :initform nil)) + (:documentation "")) + +(defun about-us-json (category &optional message errormsg) + (with-noauth (instance about-us-service) + (setf (message instance) message) + (setf (errormsg instance) errormsg) + (setf (category instance) category))) + (defun about-us-view-json (category) (with-noauth (instance about-us/view-service) (setf (category instance) category) - (with-valid-user (user "about-us-modify") - (setf (admin-p instance) nil) - (setf (admin-p instance) t)) + (setf (admin-p instance) (with-valid-user (user "about-us-modify") nil t)) (with-bogenherr-database (let* ((general-pkg (make-instance 'general-pkg)) (about-us (get-about-us general-pkg category))) (when about-us (setf (content instance) (content about-us))))))) -(defclass about-us/modify-service (about-us/view-service auth-service) - ((form :initarg :form - :initform nil - :accessor form) - (admin-p :initform t) - (location-p :initform nil)) - (:documentation "")) - (defun about-us-modify-json (category) (with-auth (instance about-us/modify-service "about-us-modify") (with-bogenherr-database @@ -51,7 +51,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 +64,19 @@ (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" :method :post) (&post (message :parameter-type 'string) (errormsg :parameter-type 'string)) about-us-json "lessons" message errormsg) +(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" :method :post) (&post (message :parameter-type 'string) (errormsg :parameter-type 'string)) about-us-json "gigs" message errormsg) +(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" :method :post) (&post (message :parameter-type 'string) (errormsg :parameter-type 'string)) about-us-json "programming" message errormsg) +(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..c830254 100644 --- a/lisp/service/base-service.lisp +++ b/lisp/service/base-service.lisp @@ -3,19 +3,221 @@ (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)))) + (setf (slot-value base-service slot) (slot-value record slot)))) (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)))) + (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..959b746 100644 --- a/lisp/service/contact-us-service.lisp +++ b/lisp/service/contact-us-service.lisp @@ -7,6 +7,16 @@ () (:documentation "")) +(defclass contact-us/view-service (contact-us-service) + ((content :initarg :content + :initform nil + :accessor content) + (form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + (defun contact-us-form () (make-form "contact-us-form" nil @@ -22,27 +32,13 @@ (with-noauth (instance contact-us-service) t)) -(defclass contact-us/view-service (contact-us-service) - ((content :initarg :content - :initform nil - :accessor content) - (form :initarg :form - :initform nil - :accessor form) - (location-p :initform nil)) - (:documentation "")) - (defun contact-us-view-json () (with-noauth (instance contact-us/view-service) (setf (form instance) (contact-us-form)))) -(defclass contact-us/email-service (contact-us/view-service) - () - (:documentation "")) - (defun contact-us-email-json (first_name last_name email phone comments) (declare (special first_name last_name email phone comments)) - (with-noauth (instance contact-us/email-service) + (with-noauth (instance contact-us/email-servicea) (with-bogenherr-database (let ((contact-pkg (make-instance 'contact-pkg)) (contact-us-post (make-instance 'contact-us-post))) @@ -78,7 +74,11 @@ :reply-to (mail-postmaster *webapp*) :ssl (mail-ssl *webapp*) :authentication (mail-authentication *webapp*)) - (setf (session-value :message) "Form submitted successfully.")) + (setf (message instance) "Form submitted successfully.")) (error (e) (declare (ignore e)) - (setf (session-value :errormsg) "Error submitting form."))))))) + (setf (errormsg instance) "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..44a7804 100644 --- a/lisp/service/gallery-service.lisp +++ b/lisp/service/gallery-service.lisp @@ -9,12 +9,6 @@ :accessor admin-p)) (:documentation "")) -(defun gallery-json () - (with-noauth (instance gallery-service) - (with-valid-user (user "gallery-modify") - (setf (admin-p instance) nil) - (setf (admin-p instance) t)))) - (defclass gallery/view-service (gallery-service) ((results :initarg :results :initform nil @@ -22,6 +16,18 @@ (location-p :initform nil)) (:documentation "")) +(defclass gallery/modify-service (gallery/view-service) + ((form :initarg :form + :initform nil + :accessor form)) + (:documentation "")) + +(defun gallery-json () + (with-noauth (instance gallery-service) + (with-valid-user (user "gallery-modify") + (setf (admin-p instance) nil) + (setf (admin-p instance) t)))) + (defun gallery-view-json () (with-noauth (instance gallery/view-service) (with-valid-user (user "gallery-modify") @@ -35,14 +41,8 @@ (loop for gallery in (results instance) do (sanitize-json gallery)))) -(defclass gallery/add-modify-delete-service (gallery/view-service) - ((form :initarg :form - :initform nil - :accessor form)) - (:documentation "")) - (defun gallery-add-json () - (with-auth (instance gallery/add-modify-delete-service "gallery-modify") + (with-auth (instance gallery/modify-service "gallery-modify") (setf (form instance) (make-form "gallery-add-form" nil t @@ -53,7 +53,7 @@ (defun gallery-add-submit-json (description video_embed_url upload) (declare (special description video_embed_url)) - (with-auth (instance gallery/add-modify-delete-service "gallery-modify") + (with-auth (instance gallery/modify-service "gallery-modify") (with-bogenherr-database (let ((general-pkg (make-instance 'general-pkg)) (gallery (make-instance 'gallery)) @@ -75,7 +75,7 @@ (setf (session-value :message) "Gallery added successfully."))))) (defun gallery-modify-json (id) - (with-auth (instance gallery/add-modify-delete-service "gallery-modify") + (with-auth (instance gallery/modify-service "gallery-modify") (with-bogenherr-database (let* ((general-pkg (make-instance 'general-pkg)) (gallery (get-gallery general-pkg id))) @@ -88,11 +88,11 @@ (:name "video_embed_url" :label "Video embed URL" :field-type "text" :value ,(video_embed_url gallery)) (:name "upload" :label "Image/Video" :field-type "file") (:label "Modify Gallery" :field-type "button" :onclick "on_gallery_modify_submit_clicked()")))) - (setf (session-value :errormsg) "Error: could not modify gallery. Not found.")))))) + (setf (errormsg instance) "Error: could not modify gallery. Not found.")))))) (defun gallery-modify-submit-json (id description video_embed_url upload) (declare (special description video_embed_url)) - (with-auth (instance gallery/add-modify-delete-service "gallery-modify") + (with-auth (instance gallery/modify-service "gallery-modify") (with-bogenherr-database (let* ((general-pkg (make-instance 'general-pkg)) (gallery (get-gallery general-pkg id))) @@ -112,19 +112,19 @@ (setf (mime_type gallery) (org-ckons-file::get-mime-type new-filepath)) (setf (content gallery) (org-ckons-file::file-as-hex new-filepath)))) (update-gallery general-pkg gallery) - (setf (session-value :message) "Gallery saved successfully.")) - (setf (session-value :errormsg) "An error occurred.")))))) + (setf (message instance) "Gallery saved successfully.")) + (setf (errormsg instance) "An error occurred.")))))) (defun gallery-delete-json (id) - (with-auth (instance gallery/add-modify-delete-service "gallery-modify") + (with-auth (instance gallery/modify-service "gallery-modify") (with-bogenherr-database (let* ((general-pkg (make-instance 'general-pkg)) (gallery (get-gallery general-pkg id))) (if gallery (progn (delete-record general-pkg gallery) - (setf (session-value :message) "Gallery deleted successfully.")) - (setf (session-value :errormsg) "Error: could not delete gallery. Not found.")))))) + (setf (message instance) "Gallery deleted successfully.")) + (setf (errormsg instance) "Error: could not delete gallery. Not found.")))))) (defun gallery-file-view (id) (with-noauth-raw (instance gallery/view-service) @@ -134,3 +134,11 @@ (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" :method :post) (&post (id :parameter-type 'integer)) gallery-delete-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..63011e5 100644 --- a/lisp/service/home-service.lisp +++ b/lisp/service/home-service.lisp @@ -9,10 +9,11 @@ :accessor content)) (:documentation "")) -(defmethod initialize-instance :after ((home-service home-service) &key) - t) - (defun home-json (&optional message errormsg) (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)))) + (setf (message instance) message) + (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..408039c 100644 --- a/lisp/service/login-service.lisp +++ b/lisp/service/login-service.lisp @@ -12,53 +12,48 @@ :accessor title)) (:documentation "")) -(defclass login-forgot-service (login-service) - () +(defclass login-authenticate-service (rest-service) + ((location-p :initform nil)) (:documentation "")) -(defmethod initialize-instance :after ((login-service login-service) &key) - (setf (title login-service) "Login") - (setf (form login-service) (make-form "login-form" - nil - t - '((:name "username" :label "Username" :field-type "text" :required "required") - (:name "pwd" :label "Password" :field-type "password" :required "required") - (:label "Login" :field-type "button" :onclick "on_login_submit_clicked()"))))) - -(defmethod initialize-instance :after ((login-forgot-service login-forgot-service) &key) - (setf (title login-forgot-service) "Reset Password") - (setf (form login-forgot-service) (make-form "login-forgot-form" - nil - t - '((:name "username" :label "Username" :field-type "text" :required "required") - (:label "Send password reset email" :field-type "button" :onclick "on_login_forgot_submit_clicked()"))))) - (defun login-json () (with-noauth (instance login-service) - t)) + (setf (title instance) "Login") + (setf (form instance) (make-form "login-form" + nil + t + '((:name "username" :label "Username" :field-type "text" :required "required") + (:name "pwd" :label "Password" :field-type "password" :required "required") + (:label "Login" :field-type "button" :onclick "on_login_submit_clicked()")))))) (defun login-forgot-json () - (with-noauth (instance login-forgot-service) - t)) - -(defclass login-authenticate-service (rest-service) - ((location-p :initform nil)) - (:documentation "")) + (with-noauth (instance login-service) + (setf (title instance) "Reset Password") + (setf (form instance) (make-form "login-forgot-form" + nil + t + '((:name "username" :label "Username" :field-type "text" :required "required") + (:label "Send password reset email" :field-type "button" :onclick "on-login-forgot-submit-clicked")))))) (defun login-authenticate-json (username pwd) (with-noauth (instance login-authenticate-service) (if (or (org-ckons-core::null-or-empty-p username) (org-ckons-core::null-or-empty-p pwd)) - (setf (session-value :errormsg) "Login failed.") + (setf (errormsg instance) "Login failed.") (with-bogenherr-database (let* ((auth-pkg (make-instance 'auth-pkg)) (user (get-active-user-by-username-pwd auth-pkg username pwd))) (cond (user (set-user user) - (setf (session-value :message) "Successfully logged in.") - (setf (session-value :errormsg) nil)) + (setf (message instance) "Successfully logged in.") + (setf (errormsg instance) nil)) (t - (setf (session-value :message) nil) - (setf (session-value :errormsg) "Login failed.")))))) - (setf (message instance) (session-value :message)) - (setf (errormsg instance) (session-value :errormsg)))) + (setf (message instance) nil) + (setf (errormsg instance) "Login failed.")))))) + (setf (message instance) (message instance)) + (setf (errormsg instance) (errormsg instance)))) + +(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/logout-service.lisp b/lisp/service/logout-service.lisp index d0564a5..169314e 100644 --- a/lisp/service/logout-service.lisp +++ b/lisp/service/logout-service.lisp @@ -10,5 +10,4 @@ (defun logout-json () (with-noauth (instance logout-service) (set-user (make-default-user)) - (setf (location instance) "/home") (setf (message instance) "You are now logged out."))) 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..9e2a419 100644 --- a/lisp/service/messages-service.lisp +++ b/lisp/service/messages-service.lisp @@ -12,25 +12,28 @@ :accessor form)) (:documentation "")) +(defclass messages/view-service (messages-service) + ((results :initarg :results + :initform nil + :accessor results) + (location-p :initform nil)) + (:documentation "")) + +(defclass messages/mark-service (messages-service) + ((location-p :initform nil)) + (:documentation "")) + (defun messages-json () (with-auth (instance messages-service "messages-view") (setf (title instance) "Messages Administration") (setf (form instance) (make-form "messages-select-mode-form" nil nil - `((:name "read" :field-type "hidden" :required "required" :value ,(session-value :messages-read)) - (:label "View Unread" :field-type "button" :onclick "on_messages_mode_clicked('unread')") + `((:label "View Unread" :field-type "button" :onclick "on_messages_mode_clicked('unread')") (:label "View Read" :field-type "button" :onclick "on_messages_mode_clicked('read')")))))) -(defclass messages/results-service (messages-service) - ((results :initarg :results - :initform nil - :accessor results) - (location-p :initform nil)) - (:documentation "")) - -(defun messages-results-json (read) - (with-auth (instance messages/results-service "messages-view") +(defun messages-view-json (read) + (with-auth (instance messages/view-service "messages-view") (when read (setf (session-value :messages-read) read)) (with-bogenherr-database (let ((contact-pkg (make-instance 'contact-pkg))) @@ -41,17 +44,17 @@ (loop for result in (results instance) do (sanitize-json result)))) -(defclass messages/mark-service (messages-service) - ((location-p :initform nil)) - (:documentation "")) - (defun messages-mark-json (read id) (with-auth (instance messages/mark-service "messages-view") (with-bogenherr-database (handler-case (let ((contact-pkg (make-instance 'contact-pkg))) (mark-contact-us-post contact-pkg id (id (get-user)) (string= read "read")) - (setf (session-value :message) (format nil "Message marked ~a successfully." read))) + (setf (message instance) (format nil "Message marked ~a successfully." read))) (error (e) (declare (ignore e)) - (setf (session-value :errormsg) (format nil "Error marking message ~a." read))))))) + (setf (errormsg instance) (format nil "Error marking message ~a." read))))))) + +(define-endpoint ("/messages" :method :get) () messages-json) +(define-endpoint ("/messages/view" :method :post) (&post (read :parameter-type 'string)) messages-view-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..ab35f09 100644 --- a/lisp/service/password-service.lisp +++ b/lisp/service/password-service.lisp @@ -12,6 +12,13 @@ :accessor title)) (:documentation "")) +(defclass password/modify-service (password-service) + ((form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + (defun password-json () (with-auth (instance password-service "profile-modify") (let ((user (get-user))) @@ -24,13 +31,6 @@ (:name "pwd2" :label "Password (again)" :field-type "password" :required "required") (:label "Change Password" :field-type "button" :onclick "on_password_submit_clicked()"))))))) -(defclass password/modify-service (password-service) - ((form :initarg :form - :initform nil - :accessor form) - (location-p :initform nil)) - (:documentation "")) - (defun password-submit-json (id pwd pwd2) (declare (special pwd pwd2)) (with-auth (instance password/modify-service "profile-modify") @@ -46,5 +46,8 @@ do (setf (slot-value user param) (symbol-value param))) (update-password auth-pkg user) (set-user user) - (setf (session-value :message) "Password saved successfully.")) - (setf (session-value :errormsg) "An error occured.")))))) + (setf (message instance) "Password saved successfully.")) + (setf (errormsg instance) "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..e8b68de 100644 --- a/lisp/service/profile-service.lisp +++ b/lisp/service/profile-service.lisp @@ -3,22 +3,18 @@ (in-package :bogenherr) -(defclass profile-service (auth-service user) +(defclass profile-service (auth-service) ((title :initarg :title :initform nil :accessor title)) (:documentation "")) -(defun profile-json () - (with-auth (instance profile-service "profile-modify") - (setf (title instance) "Profile") - (sanitize-rest-json instance))) - -(defun profile-view-json () - (with-auth (instance profile-service "profile-modify") - (let ((user (get-user))) - (copy-from-record instance user)) - (sanitize-rest-json instance))) +(defclass profile/view-service (profile-service) + ((items :initarg items + :initform nil + :accessor items) + (location-p :initform nil)) + (:documentation "")) (defclass profile/modify-service (profile-service) ((form :initarg :form @@ -27,10 +23,22 @@ (location-p :initform nil)) (:documentation "")) +(defun profile-json () + (with-auth (instance profile-service "profile-modify") + (setf (title instance) "Profile"))) + +(defun profile-view-json () + (with-auth (instance profile/view-service "profile-modify") + (let ((user (get-user))) + (setf (items instance) `(,user))) + (sanitize-rest-json instance) + (loop for item in (items instance) + do (sanitize-json item)))) + (defun profile-modify-json () (with-auth (instance profile/modify-service "profile-modify") (let ((user (get-user))) - (sanitize-rest-json instance) + (sanitize-json user) (setf (title instance) "Profile - Modify") (setf (form instance) (make-form "profile-modify-form" nil @@ -54,8 +62,12 @@ (intersection `(,x) '(id))) (sb-introspect:function-lambda-list #'profile-modify-submit-json)) do (setf (slot-value user param) (symbol-value param))) - (copy-from-record instance user) (update-user auth-pkg user) (set-user user) - (setf (session-value :message) "Profile saved successfully.")) - (setf (session-value :errormsg) "An error occured.")))))) + (setf (message instance) "Profile saved successfully.")) + (setf (errormsg instance) "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..9f9f3d7 100644 --- a/lisp/service/rest-service.lisp +++ b/lisp/service/rest-service.lisp @@ -20,12 +20,6 @@ (defmethod initialize-instance :after ((rest-service rest-service) &key) (when (location-p rest-service) - (if (message rest-service) - (setf (session-value :message) (message rest-service)) - (setf (message rest-service) (session-value :message))) - (if (errormsg rest-service) - (setf (session-value :errormsg) (errormsg rest-service)) - (setf (errormsg rest-service) (session-value :errormsg))) (when (null (location rest-service)) (setf (location rest-service) (type-to-path rest-service))))) @@ -39,3 +33,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/users-service.lisp b/lisp/service/users-service.lisp index 5b16d46..145ccdd 100644 --- a/lisp/service/users-service.lisp +++ b/lisp/service/users-service.lisp @@ -9,10 +9,6 @@ :accessor title)) (:documentation "")) -(defun users-json () - (with-auth (instance users-service "users-view") - (setf (title instance) "Users"))) - (defclass users/view-service (users-service user) ((users :initarg :users :initform nil @@ -20,6 +16,36 @@ (location-p :initform nil)) (:documentation "")) +(defclass users/modify-service (users/view-service) + ((form :initarg :form + :initform nil + :accessor form)) + (:documentation "")) + +(defclass users/register-service (rest-service) + ((title :initarg :title + :initform nil + :accessor title) + (hash :initarg :hash + :initform nil + :accessor hash)) + (:documentation "")) + +(defclass users/register/form-service (rest-service) + ((form :initarg :form + :initform nil + :accessor form) + (location-p :initform nil)) + (:documentation "")) + +(defclass users/register/submit-service (rest-service) + ((location-p :initform nil)) + (:documentation "")) + +(defun users-json () + (with-auth (instance users-service "users-view") + (setf (title instance) "Users"))) + (defun users-view-json () (with-auth (instance users/view-service "users-view") (with-bogenherr-database @@ -29,13 +55,7 @@ (loop for user in (users instance) do (sanitize-json user)))) -(defclass users/add-service (users/view-service) - ((form :initarg :form - :initform nil - :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,11 +65,11 @@ 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 () - (with-auth (instance users/add-service "users-modify") + (with-auth (instance users/modify-service "users-modify") (setf (title instance) "Users - Add") (with-bogenherr-database (let* ((auth-pkg (make-instance 'auth-pkg)) @@ -61,12 +81,12 @@ `((: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) (declare (special role_groups first_name last_name email)) - (with-auth (instance users/add-service "users-modify") + (with-auth (instance users/modify-service "users-modify") (with-bogenherr-database (let ((registration (make-instance 'registration))) (loop for param in (sb-introspect:function-lambda-list #'users-add-submit-json) @@ -95,12 +115,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)))))))) @@ -113,31 +133,15 @@ :reply-to (mail-postmaster *webapp*) :ssl (mail-ssl *webapp*) :authentication (mail-authentication *webapp*)) - (setf (session-value :message) (format nil "Email sent successfully to ~a" (email registration)))) + (setf (message instance) (format nil "Email sent successfully to ~a" (email registration)))) (error (e) - (setf (session-value :errormsg) (format nil "Error sending email to ~a. Registration failed. ~a" (email registration) e)))))))) - -(defclass users/register-service (rest-service) - ((title :initarg :title - :initform nil - :accessor title) - (hash :initarg :hash - :initform nil - :accessor hash)) - (:documentation "")) + (setf (errormsg instance) (format nil "Error sending email to ~a. Registration failed. ~a" (email registration) e)))))))) (defun users-register-json (hash) (with-noauth (instance users/register-service) (setf (title instance) "New User Registration") (setf (hash instance) hash))) -(defclass users/register/form-service (rest-service) - ((form :initarg :form - :initform nil - :accessor form) - (location-p :initform nil)) - (:documentation "")) - (defun users-register-form-json (hash) (with-noauth (instance users/register/form-service) (with-bogenherr-database @@ -145,23 +149,17 @@ (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 (session-value :errormsg) "Error: invalid registration.")))))) - -(defclass users/register/submit-service (rest-service) - ((location-p :initform nil)) - (:documentation "")) + (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 (errormsg instance) "Error: invalid registration.")))))) (defun users-register-submit-json (hash username pwd pwd2 phone) (with-noauth (instance users/register/submit-service) @@ -170,34 +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.")))))))) - -(defclass users/modify-service (users/add-service) - () - (:documentation "")) + (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 (message instance) "Registration completed successfully.")) + (setf (errormsg instance) "Error while completing registration."))) + (setf (errormsg instance) "Error: passwords do not match.")) + (setf (errormsg instance) "Error while completing registration.")))))) (defun users-modify-json (id) (with-auth (instance users/modify-service "users-modify") @@ -218,9 +211,9 @@ (: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.")))))) + (setf (errormsg instance) "Error: could not modify user. Not found.")))))) (defun users-modify-submit-json (id role_groups username first_name last_name email phone) (declare (special role_groups username first_name last_name email phone)) @@ -240,43 +233,48 @@ (cl-ppcre:split "\\|" role_groups) :test 'string=) do (insert-user-role-group auth-pkg (make-instance 'user-role - :user_id (id user) + :user_id id :role_group_name role-group))) - (setf (session-value :message) "User saved successfully.")) - (setf (session-value :errormsg) "An error occured.")))))) - -(defclass users/toggle-service (users/add-service) - () - (:documentation "")) + (setf (message instance) "User saved successfully.")) + (setf (errormsg instance) "An error occured.")))))) (defun users-toggle-active-json (id) - (with-auth (instance users/toggle-service "users-modify") + (with-auth (instance users/modify-service "users-modify") (with-bogenherr-database (let* ((auth-pkg (make-instance 'auth-pkg)) (user (get-user-by-id auth-pkg id))) (if user (if (= (id user) (id (get-user))) - (setf (session-value :errormsg) "Error: you may not toggle your own active state.") + (setf (errormsg instance) "Error: you may not toggle your own active state.") (progn (user-toggle-active auth-pkg user) - (setf (session-value :errormsg) nil) - (setf (session-value :message) "User active state toggled successfully."))) - (setf (session-value :errormsg) "Error: could not toggle the active state of the user: not found.")))))) - -(defclass users/delete-service (users/add-service) - () - (:documentation "")) + (setf (errormsg instance) nil) + (setf (message instance) "User active state toggled successfully."))) + (setf (errormsg instance) "Error: could not toggle the active state of the user: not found.")))))) (defun users-delete-json (id) - (with-auth (instance users/delete-service "users-modify") + (with-auth (instance users/modify-service "users-modify") (with-bogenherr-database (let* ((auth-pkg (make-instance 'auth-pkg)) (user (get-user-by-id auth-pkg id))) (if user (if (= (id user) (id (get-user))) - (setf (session-value :errormsg) "Error: you may not delete yourself.") + (setf (errormsg instance) "Error: you may not delete yourself.") (progn (deactivate-user auth-pkg user) - (setf (session-value :errormsg) nil) - (setf (session-value :message) "User deleted successfully."))) - (setf (session-value :errormsg) "Error: could not delete user: not found.")))))) + (setf (errormsg instance) nil) + (setf (message instance) "User deleted successfully."))) + (setf (errormsg instance) "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) -- cgit v1.3