diff options
Diffstat (limited to 'lisp/service/users-service.lisp')
| -rw-r--r-- | lisp/service/users-service.lisp | 204 |
1 files changed, 101 insertions, 103 deletions
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) |