summaryrefslogtreecommitdiff
path: root/lisp/service
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/service')
-rw-r--r--lisp/service/about-us-service.lisp66
-rw-r--r--lisp/service/auth-service.lisp48
-rw-r--r--lisp/service/base-service.lisp21
-rw-r--r--lisp/service/contact-us-service.lisp84
-rw-r--r--lisp/service/generic-form.lisp87
-rw-r--r--lisp/service/generics.lisp15
-rw-r--r--lisp/service/home-service.lisp18
-rw-r--r--lisp/service/login-service.lisp64
-rw-r--r--lisp/service/logout-service.lisp14
-rw-r--r--lisp/service/menu-service.lisp96
-rw-r--r--lisp/service/messages-service.lisp57
-rw-r--r--lisp/service/password-service.lisp50
-rw-r--r--lisp/service/profile-service.lisp61
-rw-r--r--lisp/service/rest-service.lisp41
-rw-r--r--lisp/service/users-service.lisp282
15 files changed, 1004 insertions, 0 deletions
diff --git a/lisp/service/about-us-service.lisp b/lisp/service/about-us-service.lisp
new file mode 100644
index 0000000..c479efe
--- /dev/null
+++ b/lisp/service/about-us-service.lisp
@@ -0,0 +1,66 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :resume)
+
+(defclass about-us-service (rest-service)
+ ((category :initarg :category
+ :initform nil
+ :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
+ :accessor content)
+ (admin-p :initarg :admin-p
+ :initform nil
+ :accessor admin-p)
+ (location :initform nil))
+ (:documentation ""))
+
+(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))
+ (with-resume-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-resume-database
+ (let* ((general-pkg (make-instance 'general-pkg))
+ (about-us (get-about-us general-pkg category)))
+ (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 "Modify" :field-type "button" :onclick "on_about_us_modify_submit_clicked()"))))))))
+
+(defun about-us-modify-submit-json (category content)
+ (with-auth (instance about-us/modify-service "about-us-modify")
+ (with-resume-database
+ (let* ((general-pkg (make-instance 'general-pkg))
+ (about-us (get-about-us general-pkg category)))
+ (when about-us
+ (setf (content about-us) content)
+ (update-record general-pkg about-us))))
+ (setf (content instance) content)
+ (setf (message instance) "About Us text saved successfully.")))
diff --git a/lisp/service/auth-service.lisp b/lisp/service/auth-service.lisp
new file mode 100644
index 0000000..8450e64
--- /dev/null
+++ b/lisp/service/auth-service.lisp
@@ -0,0 +1,48 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :resume)
+
+(defclass auth-service (rest-service)
+ ()
+ (:documentation ""))
+
+(defmethod initialize-instance :after ((auth-service auth-service) &key roles)
+ (with-valid-user (session roles)
+ (progn
+ (setf (location auth-service) "/home")
+ (setf (message auth-service) nil)
+ (setf (errormsg auth-service) "You are not authorized to access this resource."))
+ t))
+
+(defmacro with-auth ((instance auth-service roles) &body body)
+ `(let ((,instance (make-instance ',auth-service :roles ,roles)))
+ (when (null (errormsg ,instance))
+ ,@body)
+ (when (location-p ,instance)
+ (setf (session-value :message) nil)
+ (setf (session-value :errormsg) nil))
+ (org-ckons-json::objects-to-json `(,,instance))))
+
+(defmacro with-auth-raw ((instance auth-service roles) &body body)
+ `(let ((,instance (make-instance ',auth-service :roles ,roles)))
+ (when (location-p ,instance)
+ (setf (session-value :message) nil)
+ (setf (session-value :errormsg) nil))
+ (when (null (errormsg ,instance))
+ ,@body)))
+
+(defmacro with-noauth ((instance rest-service) &body body)
+ `(let ((,instance (make-instance ',rest-service)))
+ ,@body
+ (when (location-p ,instance)
+ (setf (session-value :message) nil)
+ (setf (session-value :errormsg) nil))
+ (org-ckons-json::objects-to-json `(,,instance))))
+
+(defmacro with-noauth-raw ((instance rest-service) &body body)
+ `(let ((,instance (make-instance ',rest-service)))
+ (when (location-p ,instance)
+ (setf (session-value :message) nil)
+ (setf (session-value :errormsg) nil))
+ ,@body))
diff --git a/lisp/service/base-service.lisp b/lisp/service/base-service.lisp
new file mode 100644
index 0000000..bd38c5a
--- /dev/null
+++ b/lisp/service/base-service.lisp
@@ -0,0 +1,21 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :resume)
+
+(defclass base-service ()
+ ()
+ (:documentation ""))
+
+(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)))
+
+(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))))
+
+(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))))
diff --git a/lisp/service/contact-us-service.lisp b/lisp/service/contact-us-service.lisp
new file mode 100644
index 0000000..43f6da3
--- /dev/null
+++ b/lisp/service/contact-us-service.lisp
@@ -0,0 +1,84 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :resume)
+
+(defclass contact-us-service (rest-service)
+ ()
+ (:documentation ""))
+
+(defun contact-us-form ()
+ (make-form "contact-us-form"
+ nil
+ t
+ `((: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")
+ (:name "phone" :label "Phone" :field-type "text")
+ (:name "comments" :label "Message" :field-type "textarea" :required "required")
+ (:label "Submit" :field-type "button" :onclick "on_contact_us_email_submit_clicked()"))))
+
+(defun contact-us-json ()
+ (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-resume-database
+ (let ((contact-pkg (make-instance 'contact-pkg))
+ (contact-us-post (make-instance 'contact-us-post)))
+ (loop for param in (sb-introspect:function-lambda-list #'contact-us-email-json)
+ do (setf (slot-value contact-us-post param) (symbol-value param)))
+ (insert-contact-us-post contact-pkg contact-us-post)
+ (handler-case
+ (let ((text-message (format nil
+ "A contact-us form submission was received.~%~%Name: ~a ~a~%Email: ~a~%Phone: ~a~%~%Message: ~a~%"
+ (first_name contact-us-post)
+ (last_name contact-us-post)
+ (email contact-us-post)
+ (phone contact-us-post)
+ (comments contact-us-post)))
+ (html-message (org-ckons-http::html5
+ `(html
+ ((p) "A contact-us form submission was received.")
+ ((p)
+ ,(format nil
+ "Name: ~a ~a<br/>Email: ~a<br/>Phone: ~a"
+ (first_name contact-us-post)
+ (last_name contact-us-post)
+ (email contact-us-post)
+ (phone contact-us-post)))
+ ((p)
+ ,(format nil "Message: ~a" (comments contact-us-post)))))))
+ (org-ckons-core::sendmail (mail-mx *webapp*)
+ (mail-postmaster *webapp*)
+ (mail-info *webapp*)
+ (format nil "~a contact-us form" (name *webapp*))
+ text-message
+ :html-message html-message
+ :reply-to (mail-postmaster *webapp*)
+ :ssl (mail-ssl *webapp*)
+ :authentication (mail-authentication *webapp*))
+ (setf (session-value :message) "Form submitted successfully."))
+ (error (e)
+ (declare (ignore e))
+ (setf (session-value :errormsg) "Error submitting form.")))))))
diff --git a/lisp/service/generic-form.lisp b/lisp/service/generic-form.lisp
new file mode 100644
index 0000000..c9742a4
--- /dev/null
+++ b/lisp/service/generic-form.lisp
@@ -0,0 +1,87 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :resume)
+
+(defclass generic-form (base-service)
+ ((name :initarg :name
+ :initform nil
+ :accessor name)
+ (http-method :initarg :http-method
+ :initform "POST"
+ :accessor http-method)
+ (action :initarg :action
+ :initform nil
+ :accessor action)
+ (required-p :initarg :required-p
+ :initform nil
+ :accessor required-p)
+ (form-fields :initarg :form-fields
+ :initform nil
+ :accessor form-fields))
+ (:documentation ""))
+
+(defclass form-field (base-service)
+ ((name :initarg :name
+ :initform nil
+ :accessor name)
+ (label :initarg :label
+ :initform nil
+ :accessor label)
+ (value :initarg :value
+ :initform nil
+ :accessor value)
+ (checked :initarg :checked
+ :initform nil
+ :accessor checked)
+ (field-type :initarg :field-type
+ :initform nil
+ :accessor field-type)
+ (required :initarg :required
+ :initform nil
+ :accessor required)
+ (dismiss :initarg :dismiss
+ :initform nil
+ :accessor dismiss)
+ (options :initarg :options
+ :initform nil
+ :accessor options)
+ (onclick :initarg :onclick
+ :initform nil
+ :accessor onclick)
+ (onchange :initarg :onchange
+ :initform nil
+ :accessor onchange))
+ (:documentation ""))
+
+(defclass option (base-service)
+ ((label :initarg :label
+ :initform nil
+ :accessor label)
+ (value :initarg :value
+ :initform nil
+ :accessor value))
+ (:documentation ""))
+
+(defun make-form (name action required-p fields)
+ (make-instance 'generic-form
+ :name name
+ :action action
+ :required-p required-p
+ :form-fields (mapcar (lambda (field)
+ (make-instance 'form-field
+ :name (getf field :name)
+ :label (getf field :label)
+ :value (getf field :value)
+ :checked (getf field :checked)
+ :field-type (getf field :field-type)
+ :required (getf field :required)
+ :dismiss (getf field :dismiss)
+ :options (mapcar (lambda (option)
+ (make-instance 'option
+ :label (getf option :label)
+ :value (getf option :value)))
+ (getf field :options))
+ :onclick (getf field :onclick)
+ :onchange (getf field :onchange)))
+ fields)))
diff --git a/lisp/service/generics.lisp b/lisp/service/generics.lisp
new file mode 100644
index 0000000..caca29b
--- /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 :resume)
+
+(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
new file mode 100644
index 0000000..8e8a740
--- /dev/null
+++ b/lisp/service/home-service.lisp
@@ -0,0 +1,18 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :resume)
+
+(defclass home-service (rest-service)
+ ((content :initarg :content
+ :initform nil
+ :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))))
diff --git a/lisp/service/login-service.lisp b/lisp/service/login-service.lisp
new file mode 100644
index 0000000..5f7dd2c
--- /dev/null
+++ b/lisp/service/login-service.lisp
@@ -0,0 +1,64 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :resume)
+
+(defclass login-service (rest-service)
+ ((form :initarg :form
+ :initform nil
+ :accessor form)
+ (title :initarg :title
+ :initform nil
+ :accessor title))
+ (:documentation ""))
+
+(defclass login-forgot-service (login-service)
+ ()
+ (: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))
+
+(defun login-forgot-json ()
+ (with-noauth (instance login-forgot-service)
+ t))
+
+(defclass login-authenticate-service (rest-service)
+ ((location-p :initform nil))
+ (:documentation ""))
+
+(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.")
+ (with-resume-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))
+ (t
+ (setf (session-value :message) nil)
+ (setf (session-value :errormsg) "Login failed."))))))
+ (setf (message instance) (session-value :message))
+ (setf (errormsg instance) (session-value :errormsg))))
diff --git a/lisp/service/logout-service.lisp b/lisp/service/logout-service.lisp
new file mode 100644
index 0000000..a3c3948
--- /dev/null
+++ b/lisp/service/logout-service.lisp
@@ -0,0 +1,14 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :resume)
+
+(defclass logout-service (rest-service)
+ ((location-p :initform nil))
+ (:documentation ""))
+
+(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
new file mode 100644
index 0000000..e7af0c3
--- /dev/null
+++ b/lisp/service/menu-service.lisp
@@ -0,0 +1,96 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :resume)
+
+(defparameter *menu-config* '((:id "a_menu_home" :label "Home" :handler "/home" :permissions "_Public")
+ (:id "a_menu_lessons" :label "About the Studio" :handler "/lessons" :permissions "_Public")
+ (:id "a_menu_gigs" :label "For Hire" :handler "/gigs" :permissions "_Public")
+ (:id "a_menu_programming" :label "Software Consulting" :handler "/programming" :permissions "_Public")
+ (:id "a_menu_contact_us" :label "Contact Me" :handler "/contact-us" :permissions "_Public")
+ (:id "a_menu_messages" :label "Messages" :handler "/messages" :permissions "messages-view")
+ (:id "a_menu_users" :label "Users" :handler "/users" :permissions "users-view")))
+
+(defparameter *menu-user-config* '((:id "a_menu_login" :label "Login" :handler "/login" :permissions "_Public")
+ (:id "a_menu_profile" :label "Edit Profile" :handler "/profile" :permissions "_Public")
+ (:id "a_menu_password" :label "Change Password" :handler "/password" :permissions "_Public")
+ (:id "a_menu_logout" :label "Logout" :handler "/logout" :permissions "_Public")))
+
+(defclass menuitem ()
+ ((id :initarg :id
+ :initform nil
+ :accessor id)
+ (label :initarg :label
+ :initform nil
+ :accessor label)
+ (handler :initarg :handler
+ :initform nil
+ :accessor handler)
+ (permissions :initarg :permissions
+ :initform nil
+ :accessor permissions)
+ (children :initarg :children
+ :initform nil
+ :accessor children))
+ (:documentation ""))
+
+(defclass menu-service (base-service)
+ ((menuitems :initarg :menuitems
+ :initform nil
+ :accessor menuitems)
+ (location-p :initarg :location-p
+ :initform nil
+ :accessor location-p))
+ (:documentation ""))
+
+(defclass menu-user-service (menu-service)
+ ((label :initarg :label
+ :initform nil
+ :accessor label)
+ (location-p :initarg :location-p
+ :initform nil
+ :accessor location-p))
+ (:documentation ""))
+
+(defmethod initialize-instance :after ((menu-service menu-service) &key user menu-config)
+ (with-resume-database
+ (let ((auth-pkg (make-instance 'auth-pkg))
+ (user-logged-in-p (and user (not (= (id user) 0))))
+ roles)
+ (setf roles (when user (get-all-roles auth-pkg user)))
+ (setf (menuitems menu-service)
+ (remove-if (lambda (menuitem)
+ (find-if (lambda (x)
+ (string= (id menuitem) x))
+ (if user-logged-in-p
+ '("a_menu_login")
+ '("a_menu_logout" "a_menu_profile" "a_menu_password"))))
+ (mapcar (lambda (x)
+ (make-instance 'menuitem
+ :id (getf x :id)
+ :label (getf x :label)
+ :handler (getf x :handler)
+ :permissions (getf x :permissions)))
+ (remove-if 'null (mapcar (lambda (x)
+ (when (find-if (lambda (y)
+ (string= (getf x :permissions) y))
+ (mapcar (lambda (z)
+ (role_name z))
+ roles))
+ x))
+ menu-config))))))))
+
+(defun menu-json ()
+ (org-ckons-json::objects-to-json `(,(make-instance 'menu-service
+ :user (get-user)
+ :menu-config *menu-config*))))
+
+(defun menu-user-json ()
+ (let* ((user (get-user))
+ (instance (make-instance 'menu-user-service
+ :user user
+ :menu-config *menu-user-config*)))
+ (setf (label instance) (if user
+ (format nil "~a ~a" (first_name user) (last_name user))
+ "No User Found"))
+ (org-ckons-json::objects-to-json `(,instance))))
diff --git a/lisp/service/messages-service.lisp b/lisp/service/messages-service.lisp
new file mode 100644
index 0000000..9dc047a
--- /dev/null
+++ b/lisp/service/messages-service.lisp
@@ -0,0 +1,57 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :resume)
+
+(defclass messages-service (auth-service)
+ ((title :initarg :title
+ :initform nil
+ :accessor title)
+ (form :initarg :form
+ :initform nil
+ :accessor form))
+ (: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 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")
+ (when read (setf (session-value :messages-read) read))
+ (with-resume-database
+ (let ((contact-pkg (make-instance 'contact-pkg)))
+ (setf (results instance) (get-contact-us-posts contact-pkg
+ (id (get-user))
+ (string= (session-value :messages-read) "read")))))
+ (sanitize-rest-json instance)
+ (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-resume-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)))
+ (error (e)
+ (declare (ignore e))
+ (setf (session-value :errormsg) (format nil "Error marking message ~a." read)))))))
diff --git a/lisp/service/password-service.lisp b/lisp/service/password-service.lisp
new file mode 100644
index 0000000..31b51b8
--- /dev/null
+++ b/lisp/service/password-service.lisp
@@ -0,0 +1,50 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :resume)
+
+(defclass password-service (auth-service user)
+ ((form :initarg :form
+ :initform nil
+ :accessor form)
+ (title :initarg :title
+ :initform nil
+ :accessor title))
+ (:documentation ""))
+
+(defun password-json ()
+ (with-auth (instance password-service "profile-modify")
+ (let ((user (get-user)))
+ (setf (title instance) "Change Password")
+ (setf (form instance) (make-form "password-form"
+ nil
+ t
+ `((:name "id" :label "" :field-type "hidden" :value ,(id user) :required "required")
+ (:name "pwd" :label "Password" :field-type "password" :required "required")
+ (: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")
+ (setf (title instance) "Change Password")
+ (with-resume-database
+ (let ((user (get-user)))
+ (if (and (= id (id user))
+ (string= pwd pwd2))
+ (let ((auth-pkg (make-instance 'auth-pkg)))
+ (loop for param in (remove-if (lambda (x)
+ (intersection `(,x) '(id pwd2)))
+ (sb-introspect:function-lambda-list #'password-submit-json))
+ 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."))))))
diff --git a/lisp/service/profile-service.lisp b/lisp/service/profile-service.lisp
new file mode 100644
index 0000000..9e37bbf
--- /dev/null
+++ b/lisp/service/profile-service.lisp
@@ -0,0 +1,61 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :resume)
+
+(defclass profile-service (auth-service user)
+ ((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/modify-service (profile-service)
+ ((form :initarg :form
+ :initform nil
+ :accessor form)
+ (location-p :initform nil))
+ (:documentation ""))
+
+(defun profile-modify-json ()
+ (with-auth (instance profile/modify-service "profile-modify")
+ (let ((user (get-user)))
+ (sanitize-rest-json instance)
+ (setf (title instance) "Profile - Modify")
+ (setf (form instance) (make-form "profile-modify-form"
+ nil
+ t
+ `((:name "id" :label "" :field-type "hidden" :value ,(id user) :required "required")
+ (:name "username" :label "Username" :field-type "text" :value ,(username user) :required "required")
+ (:name "first_name" :label "First Name" :field-type "text" :value ,(first_name user) :required "required")
+ (: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))
+ (:label "Modify Profile" :field-type "button" :onclick "on_profile_modify_submit_clicked()")))))))
+
+(defun profile-modify-submit-json (id username first_name last_name email phone)
+ (declare (special username first_name last_name email phone))
+ (with-auth (instance profile/modify-service "profile-modify")
+ (with-resume-database
+ (let ((user (get-user)))
+ (if (= (id user) id)
+ (let ((auth-pkg (make-instance 'auth-pkg)))
+ (loop for param in (remove-if (lambda (x)
+ (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."))))))
diff --git a/lisp/service/rest-service.lisp b/lisp/service/rest-service.lisp
new file mode 100644
index 0000000..92274d6
--- /dev/null
+++ b/lisp/service/rest-service.lisp
@@ -0,0 +1,41 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :resume)
+
+(defclass rest-service (base-service)
+ ((location :initarg :location
+ :initform nil
+ :accessor location)
+ (location-p :initarg :location-p
+ :initform t
+ :accessor location-p)
+ (errormsg :initarg :errormsg
+ :initform nil
+ :accessor errormsg)
+ (message :initarg :message
+ :initform nil
+ :accessor message))
+ (:documentation ""))
+
+(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)))))
+
+(defun location-json (&optional (location "/home"))
+ (format nil "{\"location\":\"~a\"}" location))
+
+(defun type-to-path (rest-type)
+ (concatenate 'string "/" (ppcre:regex-replace "-service$" (string-downcase (type-of rest-type)) "")))
+
+(defmethod sanitize-rest-json ((rest-service rest-service))
+ (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)))
diff --git a/lisp/service/users-service.lisp b/lisp/service/users-service.lisp
new file mode 100644
index 0000000..a626971
--- /dev/null
+++ b/lisp/service/users-service.lisp
@@ -0,0 +1,282 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package :resume)
+
+(defclass users-service (auth-service)
+ ((title :initarg :title
+ :initform nil
+ :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
+ :accessor users)
+ (location-p :initform nil))
+ (:documentation ""))
+
+(defun users-view-json ()
+ (with-auth (instance users/view-service "users-view")
+ (with-resume-database
+ (let ((auth-pkg (make-instance 'auth-pkg)))
+ (setf (users instance) (get-all-users auth-pkg))))
+ (sanitize-rest-json instance)
+ (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)
+ (remove-if 'null
+ (mapcar (lambda (role-group)
+ (when (not (intersection `(,(name role-group)) `("_Public" "profile-admin") :test 'string=))
+ (let ((checked (when (intersection `(,(name role-group))
+ (mapcar (lambda (x)
+ (name x))
+ 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)))))
+ role-groups)))
+
+(defun users-add-json ()
+ (with-auth (instance users/add-service "users-modify")
+ (setf (title instance) "Users - Add")
+ (with-resume-database
+ (let* ((auth-pkg (make-instance 'auth-pkg))
+ (user (get-user))
+ (role-groups (get-all-role-groups auth-pkg user)))
+ (setf (form instance) (make-form "users-add-form"
+ nil
+ t
+ `((: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)
+ (: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-resume-database
+ (let ((registration (make-instance 'registration)))
+ (loop for param in (sb-introspect:function-lambda-list #'users-add-submit-json)
+ do (setf (slot-value registration param) (symbol-value param)))
+ (let* ((auth-pkg (make-instance 'auth-pkg))
+ (id (insert-registration auth-pkg registration)))
+ (setf registration (get-registration-by-id auth-pkg id)))
+ (handler-case
+ (let ((text-message (format nil
+ "Hello ~a ~a and welcome to the ~a website!~%~%A user account registration has been created for you. It expires in 3 days.~%~%Please click the following link to complete the registration:~%~%~a://~a/register?hash=~a~%"
+ (name *webapp*)
+ (first_name registration)
+ (last_name registration)
+ (scheme *webapp*)
+ (url *webapp*)
+ (hash registration)))
+ (html-message (org-ckons-http::html5
+ `(html
+ ((p)
+ ,(format nil
+ "Hello ~a ~a and welcome to ~a!"
+ (name *webapp*)
+ (first_name registration)
+ (last_name registration)))
+ ((p) "A user account registration has been created for you. It expires in 3 days.")
+ ((p) "Please click the following link to complete the registration:")
+ ((p)
+ ((a :href ,(format nil
+ "~a://~a/register?hash=~a"
+ (scheme *webapp*)
+ (url *webapp*)
+ (hash registration)))
+ ,(format nil
+ "~a://~a/register?hash=~a"
+ (scheme *webapp*)
+ (url *webapp*)
+ (hash registration))))))))
+ (org-ckons-core::sendmail (mail-mx *webapp*)
+ (mail-info *webapp*)
+ (email registration)
+ (format nil "~a website registration" (name *webapp*))
+ text-message
+ :html-message html-message
+ :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))))
+ (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 ""))
+
+(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-resume-database
+ (let* ((auth-pkg (make-instance 'auth-pkg))
+ (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 ""))
+
+(defun users-register-submit-json (hash username pwd pwd2 phone)
+ (with-noauth (instance users/register/submit-service)
+ (with-resume-database
+ (let ((auth-pkg (make-instance 'auth-pkg))
+ 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 ""))
+
+(defun users-modify-json (id)
+ (with-auth (instance users/modify-service "users-modify")
+ (setf (title instance) "Users - Modify")
+ (with-resume-database
+ (let* ((auth-pkg (make-instance 'auth-pkg))
+ (me (get-user))
+ (user (get-user-by-id auth-pkg id))
+ (role-groups (get-all-role-groups auth-pkg me))
+ (active-role-groups (get-active-role-groups auth-pkg user)))
+ (if user
+ (setf (form instance) (make-form "users-modify-form"
+ nil
+ t
+ `((:name "id" :field-type "hidden" :value ,(id user) :required "required")
+ (:name "username" :label "Username" :field-type "text" :value ,(username user) :required "required")
+ (:name "first_name" :label "First Name" :field-type "text" :value ,(first_name user) :required "required")
+ (: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)
+ (:label "Modify User" :field-type "button" :onclick "on_users_modify_submit_clicked()"))))
+ (setf (session-value :errormsg) "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))
+ (with-auth (instance users/modify-service "users-modify")
+ (with-resume-database
+ (let* ((auth-pkg (make-instance 'auth-pkg))
+ (user (get-active-user-by-id auth-pkg id)))
+ (if user
+ (progn
+ (loop for param in (remove-if (lambda (x)
+ (intersection `(,x) '(id role_groups)))
+ (sb-introspect:function-lambda-list #'users-modify-submit-json))
+ do (setf (slot-value user param) (symbol-value param)))
+ (update-user auth-pkg user)
+ (delete-role-groups auth-pkg user)
+ (loop for role-group in (union '("profile-admin")
+ (cl-ppcre:split "\\|" role_groups)
+ :test 'string=)
+ do (insert-user-role-group auth-pkg (make-instance 'user-role
+ :user_id (id user)
+ :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 ""))
+
+(defun users-toggle-active-json (id)
+ (with-auth (instance users/toggle-service "users-modify")
+ (with-resume-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.")
+ (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 ""))
+
+(defun users-delete-json (id)
+ (with-auth (instance users/delete-service "users-modify")
+ (with-resume-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.")
+ (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."))))))
generated by cgit v1.3 (git 2.53.0) at 2026-09-24 14:44:02 +0000