From b8423f4d05c75094b7b9d09c6f0bb353acc9be1c Mon Sep 17 00:00:00 2001 From: ckonstanski Date: Sat, 25 May 2024 18:03:25 -0600 Subject: initial commit --- lisp/sql/about-us.lisp | 15 +++ lisp/sql/auth-pkg.lisp | 205 +++++++++++++++++++++++++++++++++++++++++ lisp/sql/contact-pkg.lisp | 32 +++++++ lisp/sql/contact-us.lisp | 50 ++++++++++ lisp/sql/general-pkg.lisp | 14 +++ lisp/sql/generics.lisp | 145 +++++++++++++++++++++++++++++ lisp/sql/registration.lisp | 42 +++++++++ lisp/sql/role-group.lisp | 24 +++++ lisp/sql/testimonials.lisp | 15 +++ lisp/sql/user-role.lisp | 36 ++++++++ lisp/sql/user-session-pkg.lisp | 112 ++++++++++++++++++++++ lisp/sql/user-session.lisp | 35 +++++++ lisp/sql/user.lisp | 50 ++++++++++ 13 files changed, 775 insertions(+) create mode 100644 lisp/sql/about-us.lisp create mode 100644 lisp/sql/auth-pkg.lisp create mode 100644 lisp/sql/contact-pkg.lisp create mode 100644 lisp/sql/contact-us.lisp create mode 100644 lisp/sql/general-pkg.lisp create mode 100644 lisp/sql/generics.lisp create mode 100644 lisp/sql/registration.lisp create mode 100644 lisp/sql/role-group.lisp create mode 100644 lisp/sql/testimonials.lisp create mode 100644 lisp/sql/user-role.lisp create mode 100644 lisp/sql/user-session-pkg.lisp create mode 100644 lisp/sql/user-session.lisp create mode 100644 lisp/sql/user.lisp (limited to 'lisp/sql') diff --git a/lisp/sql/about-us.lisp b/lisp/sql/about-us.lisp new file mode 100644 index 0000000..51e4409 --- /dev/null +++ b/lisp/sql/about-us.lisp @@ -0,0 +1,15 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :woodriverlessons) + +(defclass about-us (postgres-record) + ((id :initarg :id + :initform nil + :accessor id) + (content :initarg :content + :initform nil + :accessor content) + (*table :initform "general.about_us") + (*where-expression :initform "id = ~a")) + (:documentation "Holds the data for a general.about_us type.")) diff --git a/lisp/sql/auth-pkg.lisp b/lisp/sql/auth-pkg.lisp new file mode 100644 index 0000000..54f8c3e --- /dev/null +++ b/lisp/sql/auth-pkg.lisp @@ -0,0 +1,205 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :woodriverlessons) + +(defparameter *authenticated-user-session-key* "authenticated-user") + +(defclass auth-pkg (record-pkg) + () + (:documentation "")) + +(defmethod insert-user ((auth-pkg auth-pkg) user) + (setf (*table user) (format nil + "auth.insert_user('~a', '~a', '~a', '~a', '~a', '~a', '~a')" + (username user) + (pwd user) + (first_name user) + (last_name user) + (email user) + (phone user) + (active user))) + (setf (id user) (caar (call-pg-function auth-pkg user))) + (id user)) + +(defmethod update-user ((auth-pkg auth-pkg) user) + (setf (*table user) (format nil + "auth.update_user(~a, '~a', '~a', '~a', '~a', '~a')" + (id user) + (username user) + (first_name user) + (last_name user) + (email user) + (phone user))) + (caar (call-pg-function auth-pkg user))) + +(defmethod get-all-active-users ((auth-pkg auth-pkg)) + (let ((user (make-instance 'user))) + (setf (*table user) "auth.get_all_active_users()") + (get-records auth-pkg user "first_name asc, last_name asc"))) + +(defmethod get-all-users ((auth-pkg auth-pkg)) + (let ((user (make-instance 'user))) + (setf (*table user) "auth.get_all_users()") + (get-records auth-pkg user "first_name asc, last_name asc"))) + +(defmethod get-active-user-by-username-pwd ((auth-pkg auth-pkg) username pwd) + (let ((user (make-instance 'user))) + (setf (*table user) (format nil + "auth.get_active_user_by_username_pwd('~a', '~a')" + username + pwd)) + (get-record auth-pkg user))) + +(defmethod get-active-user-by-id ((auth-pkg auth-pkg) id) + (let ((user (make-instance 'user))) + (setf (*table user) (format nil "auth.get_active_user_by_id(~a)" id)) + (get-record auth-pkg user))) + +(defmethod get-user-by-id ((auth-pkg auth-pkg) id) + (let ((user (make-instance 'user))) + (setf (*table user) (format nil "auth.get_user_by_id(~a)" id)) + (get-record auth-pkg user))) + +(defmethod user-toggle-active ((auth-pkg auth-pkg) (user user)) + (setf (*table user) (format nil "auth.user_toggle_active(~a)" (id user))) + (call-pg-function auth-pkg user)) + +(defmethod deactivate-user ((auth-pkg auth-pkg) (user user)) + (setf (*table user) (format nil "auth.user_delete(~a)" (id user))) + (call-pg-function auth-pkg user)) + +(defmethod get-all-roles ((auth-pkg auth-pkg) (user user)) + (let ((user-role (make-instance 'user-role + :*table (format nil + "auth.get_all_roles_for_user(~a)" + (id user))))) + (get-records auth-pkg user-role nil))) + +(defmethod has-role ((auth-pkg auth-pkg) (user user) role) + (let ((user-role (make-instance 'user-role))) + (setf (*table user-role) (format nil (*table user-role) (id user) role)) + (get-record auth-pkg user-role))) + +(defmethod get-all-role-groups ((auth-pkg auth-pkg) (user user)) + (let ((role-group (make-instance 'role-group))) + (setf (*table role-group) (format nil (*table role-group) (id user))) + (get-records auth-pkg role-group nil))) + +(defmethod get-role-group-by-name ((auth-pkg auth-pkg) (user user) name) + (find-if (lambda (x) + (string= name (name x))) + (get-all-role-groups auth-pkg user))) + +(defmethod get-active-role-groups ((auth-pkg auth-pkg) (user user)) + (let ((role-group (make-instance 'role-group + :*table (format nil + "auth.get_active_role_groups_for_user(~a)" + (id user))))) + (get-records auth-pkg role-group nil))) + +(defmethod insert-user-role-group ((auth-pkg auth-pkg) (user-role user-role)) + (setf (*table user-role) (format nil + "auth.insert_user_role_group(~a, '~a')" + (user_id user-role) + (role_group_name user-role))) + (caar (call-pg-function auth-pkg user-role))) + +(defmethod insert-registration ((auth-pkg auth-pkg) (registration registration)) + (setf (*table registration) (format nil + "auth.insert_registration('~a', '~a', '~a', '~a')" + (first_name registration) + (last_name registration) + (email registration) + (role_groups registration))) + (setf (id registration) (caar (call-pg-function auth-pkg registration))) + (id registration)) + +(defmethod delete-role-groups ((auth-pkg auth-pkg) user) + (let ((role-group (make-instance 'role-group + :*table (format nil + "auth.delete_role_groups_for_user(~a)" + (id user))))) + (call-pg-function auth-pkg role-group))) + +(defmethod get-registration-by-id ((auth-pkg auth-pkg) id) + (let ((registration (make-instance 'registration + :*table (format nil "auth.get_registration_by_id(~a)" id)))) + (get-record auth-pkg registration))) + +(defmethod get-registration-by-hash ((auth-pkg auth-pkg) hash) + (let ((registration (make-instance 'registration + :*table (format nil "auth.get_registration_by_hash('~a')" hash)))) + (get-record auth-pkg registration))) + +(defmethod registrations-gc ((auth-pkg auth-pkg)) + (let ((registration (make-instance 'registration :*table "auth.registrations_gc()"))) + (call-pg-function auth-pkg registration))) + +(defmethod delete-registration ((auth-pkg auth-pkg) hash) + (let ((registration (make-instance 'registration + :*table (format nil "auth.delete_registration('~a')" hash)))) + (call-pg-function auth-pkg registration))) + +(defmethod update-profile ((auth-pkg auth-pkg) (user user)) + (setf (*table user) (format nil + "auth.update_profile(~a, '~a', '~a', '~a', '~a', '~a')" + (id user) + (username user) + (first_name user) + (last_name user) + (email user) + (phone user))) + (call-pg-function auth-pkg user)) + +(defmethod update-password ((auth-pkg auth-pkg) (user user)) + (setf (*table user) (format nil "auth.update_password(~a, '~a')" (id user) (pwd user))) + (call-pg-function auth-pkg user)) + +(defmacro with-valid-user ((session-name roles) error-body &body body) + "Runs `body' if there is a valid authenticated `user' in the +`user-session' whose roles match `roles', otherwise runs +`error-body'. If a valid `user' exists, it will be bound to +`session-name'." + `(let ((,session-name (get-session-object *authenticated-user-session-key*))) + (if ,session-name + (let* ((auth-pkg (make-instance 'auth-pkg)) + (has-all-roles-p (let ((has-all-roles-p t)) + (with-woodriverlessons-database + (loop for role in (if (listp ,roles) ,roles (list ,roles)) do + (when (not (has-role auth-pkg ,session-name role)) + (setf has-all-roles-p nil))) + has-all-roles-p)))) + (if has-all-roles-p + ,@body + ,error-body)) + ,error-body))) + +(defun make-default-user () + "Convenience function for making a new instance of `user' that has +its session key set to `authenticated-user', but has no privileges." + (make-instance 'user + :*session-key *authenticated-user-session-key* + :id 0 + :first_name "Guest" + :last_name "User")) + +(defun ensure-user-exists () + "Ensures that there is an `authenticated-user' in the user session, +even if it's just a guest user." + (let ((user (get-session-object *authenticated-user-session-key*))) + (unless user + (setf user (make-default-user)) + (set-user user)))) + +(defun get-user () + "Convenience function for getting the `authenticated-user' from user +session." + (get-session-object *authenticated-user-session-key*)) + +(defun set-user (user) + "Convenience function for setting the `authenticated-user' into the +user session." + (setf (*table user) "auth.users") + (setf (pwd user) nil) + (set-session-object *authenticated-user-session-key* user)) diff --git a/lisp/sql/contact-pkg.lisp b/lisp/sql/contact-pkg.lisp new file mode 100644 index 0000000..390d861 --- /dev/null +++ b/lisp/sql/contact-pkg.lisp @@ -0,0 +1,32 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :woodriverlessons) + +(defclass contact-pkg (record-pkg) + () + (:documentation "")) + +(defmethod get-contact-us-posts ((contact-pkg contact-pkg) user-id read-p) + (let ((contact-us-post (make-instance 'contact-us-post))) + (setf (*table contact-us-post) (format nil (*table contact-us-post) user-id (if read-p "t" "f"))) + (get-records contact-pkg contact-us-post nil))) + +(defmethod insert-contact-us-post ((contact-pkg contact-pkg) (contact-us-post contact-us-post)) + (setf (*table contact-us-post) (format nil + "contact.insert_contact_us_post('~a', '~a', '~a', '~a', '~a')" + (first_name contact-us-post) + (last_name contact-us-post) + (email contact-us-post) + (phone contact-us-post) + (comments contact-us-post))) + (caar (call-pg-function contact-pkg contact-us-post))) + +(defmethod mark-contact-us-post ((contact-pkg contact-pkg) contact-us-post-id user-id read-p) + (let ((contact-us-post (make-instance 'contact-us-post + :*table (format nil + "contact.mark_contact_us_post(~a, ~a, '~a')" + contact-us-post-id + user-id + (if read-p "t" "f"))))) + (call-pg-function contact-pkg contact-us-post))) diff --git a/lisp/sql/contact-us.lisp b/lisp/sql/contact-us.lisp new file mode 100644 index 0000000..9a7f30b --- /dev/null +++ b/lisp/sql/contact-us.lisp @@ -0,0 +1,50 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :woodriverlessons) + +(defclass contact-us (postgres-record) + ((id :initarg :id + :initform nil + :accessor id) + (content :initarg :content + :initform nil + :accessor content) + (*table :initform "contact.contact_us") + (*where-expression :initform "id = ~a")) + (:documentation "Holds the data for a contact.contact_us type.")) + +(defclass contact-us-post (postgres-record) + ((id :initarg :id + :initform nil + :accessor id) + (first_name :initarg :first_name + :initform nil + :accessor first_name) + (last_name :initarg :last_name + :initform nil + :accessor last_name) + (email :initarg :email + :initform nil + :accessor email) + (phone :initarg :phone + :initform nil + :accessor phone) + (submitted :initarg :submitted + :initform nil) + (comments :initarg :comments + :initform nil + :accessor comments) + (*table :initform "contact.get_contact_us_posts_by_id_and_read(~a, '~a')") + (*where-expression :initform nil)) + (:documentation "Holds the data for a contact.contact_us_posts type.")) + +(defmethod submitted ((contact-us-post contact-us-post)) + (slot-value contact-us-post 'submitted)) + +(defmethod (setf submitted) (value (contact-us-post contact-us-post)) + (handler-case + (setf (slot-value contact-us-post 'submitted) (simple-date-to-date value)) + (error (e) + (declare (ignore e)) + (setf (slot-value contact-us-post 'submitted) nil)))) diff --git a/lisp/sql/general-pkg.lisp b/lisp/sql/general-pkg.lisp new file mode 100644 index 0000000..162d60b --- /dev/null +++ b/lisp/sql/general-pkg.lisp @@ -0,0 +1,14 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :woodriverlessons) + +(defclass general-pkg (record-pkg) + () + (:documentation "")) + +(defmethod get-about-us ((general-pkg general-pkg)) + (car (get-records general-pkg (make-instance 'about-us) nil))) + +(defmethod get-testimonials ((general-pkg general-pkg)) + (car (get-records general-pkg (make-instance 'testimonials) nil))) diff --git a/lisp/sql/generics.lisp b/lisp/sql/generics.lisp new file mode 100644 index 0000000..708856a --- /dev/null +++ b/lisp/sql/generics.lisp @@ -0,0 +1,145 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :woodriverlessons) + +(defmacro with-woodriverlessons-database (&body body) + `(with-database (getf (databases *webapp*) :db-woodriverlessons) ,@body)) + +(defgeneric insert-user (auth-pkg user) + (:documentation "Inserts a new user into the database.")) + +(defgeneric update-user (auth-pkg user) + (:documentation "Updates a user in the database.")) + +(defgeneric get-all-active-users (record-pkg) + (:documentation "Calls `get_all_active_users'.")) + +(defgeneric get-all-users (record-pkg) + (:documentation "Calls `get_all_users'.")) + +(defgeneric get-active-user-by-username-pwd (record-pkg username pwd) + (:documentation "Calls `get_active_user_by_username_pwd'.")) + +(defgeneric get-active-user-by-id (record-pkg id) + (:documentation "Calls `get_active_user_by_id'.")) + +(defgeneric get-user-by-id (record-pkg id) + (:documentation "Calls `get_user_by_id'.")) + +(defgeneric user-toggle-active (record-pkg user) + (:documentation "Calls `user_toggle_active'.")) + +(defgeneric user-delete (record-pkg user) + (:documentation "Calls `user_delete'.")) + +(defgeneric get-all-roles (record-pkg record) + (:documentation "Returns all the roles for a `user'.")) + +(defgeneric has-role (record-pkg record role) + (:documentation "Returns `t' when the user exists and has the +specified `role', `nil' otherwise.")) + +(defgeneric get-all-role-groups (auth-pkg user) + (:documentation "Returns all the role-groups for a `user'.")) + +(defgeneric get-role-group-by-name (auth-pkg user name) + (:documentation "Returns a role-group by `name' for a `user'.")) + +(defgeneric get-active-role-groups (auth-pkg user) + (:documentation "Returns all the role-groups for a `user' that are +actually present in `auth.users_role_groups', in other words the +role-groups that are assigned to the user without any superuser +magic.")) + +(defgeneric insert-user-role-group (auth-pkg user-role) + (:documentation "Idempotently inserts a new record into +auth.user_role_groups based on the user ID and the role group name.")) + +(defgeneric delete-role-groups (auth-pkg user) + (:documentation "Delete all role-group assignments for a user.")) + +(defgeneric update-profile (record-pkg record) + (:documentation "")) + +(defgeneric update-password (auth-pkg user) + (:documentation "")) + +(defgeneric get-user-sessions (record-pkg) + (:documentation "Gets all user session records.")) + +(defgeneric get-user-session (record-pkg &optional sessionid) + (:documentation "")) + +(defgeneric update-timestamp (record-pkg record) + (:documentation "Updates the timestamp of the `user-session'.")) + +(defgeneric get-user-session-objects (record-pkg record) + (:documentation "Get all user session objects associated with a user +session.")) + +(defgeneric get-user-session-object (record-pkg session-key) + (:documentation "")) + +(defgeneric flush-user-session-object (record-pkg session-key) + (:documentation "")) + +(defgeneric create-user-session (record-pkg) + (:documentation "Creates a new user session and returns the +sessionid.")) + +(defgeneric get-about-us (record-pkg) + (:documentation "Gets the one and only general.about_us record.")) + +(defgeneric get-testimonials (record-pkg) + (:documentation "Gets the one and only general.testimonials record.")) + +(defgeneric get-contact-us-posts (record-pkg user-id read-p) + (:documentation "Gets contact.contact_us_posts records.")) + +(defgeneric insert-contact-us-post (contact-pkg contact-us-post) + (:documentation "Inserts a new contact-us post into +contact.contact_us_posts. Returns the ID of the new record.")) + +(defgeneric mark-contact-us-post (contact-pkg contact-us-post-id user-id read-p) + (:documentation "Marks or unmarks a contact-us post as read.")) + +(defgeneric insert-registration (auth-pkg registration) + (:documentation "Inserts a new registration into +auth.registrations. Returns the ID of the new record.")) + +(defgeneric get-registration-by-id (auth-pkg id) + (:documentation "Gets the record from auth.registrations with the +given `id'.")) + +(defgeneric get-registration-by-hash (auth-pkg hash) + (:documentation "Gets the record from auth.registrations with the +given `hash'.")) + +(defgeneric registrations-gc (auth-pkg) + (:documentation "Garbage collects registrations that are more than 3 +days old.")) + +(defgeneric delete-registration (auth-pkg hash) + (:documentation "Deletes a registration with the given `hash'.")) + +(defgeneric event_date (record) + (:documentation "Reader for the event_date field. Converts a +local-time::timestamp to a SQL date string.")) + +(defgeneric (setf event_date) (value record) + (:documentation "Writer for the event_date field.")) + +(defgeneric submitted (record) + (:documentation "Reader for the submitted field. Converts a +local-time::timestamp to a SQL date string.")) + +(defgeneric (setf submitted) (value record) + (:documentation "Writer for the submitted field.")) + +(defgeneric created (record) + (:documentation "Reader for the created field. Converts a +local-time::timestamp to a SQL date string.")) + +(defgeneric (setf created) (value record) + (:documentation "Writer for the created field.")) diff --git a/lisp/sql/registration.lisp b/lisp/sql/registration.lisp new file mode 100644 index 0000000..a1a2919 --- /dev/null +++ b/lisp/sql/registration.lisp @@ -0,0 +1,42 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :woodriverlessons) + +(defclass registration (postgres-record) + ((id :initarg :id + :initform nil + :accessor id) + (hash :initarg :hash + :initform nil + :accessor hash) + (first_name :initarg :first_name + :initform nil + :accessor first_name) + (last_name :initarg :last_name + :initform nil + :accessor last_name) + (email :initarg :email + :initform nil + :accessor email) + (role_groups :initarg :role_groups + :initform nil + :accessor role_groups) + (created :initarg :created + :initform nil) + (valid_for :initarg :valid_for + :initform nil + :accessor valid_for) + (*table :initform "auth.registrations") + (*where-expression :initform "id = ~a")) + (:documentation "Holds the data for an auth.registrations type.")) + +(defmethod created ((registration registration)) + (slot-value registration 'created)) + +(defmethod (setf created) (value (registration registration)) + (handler-case + (setf (slot-value registration 'created) (simple-date-to-date value)) + (error (e) + (declare (ignore e)) + (setf (slot-value registration 'created) nil)))) diff --git a/lisp/sql/role-group.lisp b/lisp/sql/role-group.lisp new file mode 100644 index 0000000..50d73f7 --- /dev/null +++ b/lisp/sql/role-group.lisp @@ -0,0 +1,24 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :woodriverlessons) + +(defclass role-group (postgres-record) + ((user_role_group_id :initarg :user_role_group_id + :initform nil + :accessor user_role_group_id) + (user_id :initarg :user_id + :initform nil + :accessor user_id) + (role_group_id :initarg :role_group_id + :initform nil + :accessor role_group_id) + (name :initarg :name + :initform nil + :accessor name) + (description :initarg :description + :initform nil + :accessor description) + (*table :initform "auth.get_all_role_groups_for_user(~a)") + (*where-expression :initform nil)) + (:documentation "Holds the data for an auth.role_group_t type.")) diff --git a/lisp/sql/testimonials.lisp b/lisp/sql/testimonials.lisp new file mode 100644 index 0000000..37ac3d3 --- /dev/null +++ b/lisp/sql/testimonials.lisp @@ -0,0 +1,15 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :woodriverlessons) + +(defclass testimonials (postgres-record) + ((id :initarg :id + :initform nil + :accessor id) + (content :initarg :content + :initform nil + :accessor content) + (*table :initform "general.testimonials") + (*where-expression :initform "id = ~a")) + (:documentation "Holds the data for a general.testimonials type.")) diff --git a/lisp/sql/user-role.lisp b/lisp/sql/user-role.lisp new file mode 100644 index 0000000..3042aab --- /dev/null +++ b/lisp/sql/user-role.lisp @@ -0,0 +1,36 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :woodriverlessons) + +(defclass user-role (postgres-record) + ((user_role_group_id :initarg :user_role_group_id + :initform nil + :accessor user_role_group_id) + (user_id :initarg :user_id + :initform nil + :accessor user_id) + (role_group_id :initarg :role_group_id + :initform nil + :accessor role_group_id) + (role_group_name :initarg :role_group_name + :initform nil + :accessor role_group_name) + (role_group_description :initarg :role_group_description + :initform nil + :accessor role_group_description) + (role_group_role_id :initarg :role_group_role_id + :initform nil + :accessor role_group_role_id) + (role_id :initarg :role_id + :initform nil + :accessor role_id) + (role_name :initarg :role_name + :initform nil + :accessor role_name) + (role_description :initarg :role_description + :initform nil + :accessor role_description) + (*table :initform "auth.has_role(~a, '~a')") + (*where-expression :initform nil)) + (:documentation "Holds the data for an auth.user_role_t type.")) diff --git a/lisp/sql/user-session-pkg.lisp b/lisp/sql/user-session-pkg.lisp new file mode 100644 index 0000000..8741fff --- /dev/null +++ b/lisp/sql/user-session-pkg.lisp @@ -0,0 +1,112 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :woodriverlessons) + +(defclass user-session-pkg (record-pkg) + () + (:documentation "Database-backed user session API.")) + +(defmethod get-user-sessions ((user-session-pkg user-session-pkg)) + (get-records user-session-pkg (make-instance 'user-session) "sessionid ASC")) + +(defmethod get-user-session ((user-session-pkg user-session-pkg) &optional (sessionid *sessionid*)) + (when sessionid + (get-record user-session-pkg (make-instance 'user-session :sessionid sessionid)))) + +(defmethod update-timestamp ((user-session-pkg user-session-pkg) (user-session user-session)) + (setf (datetime user-session) (get-universal-time)) + (update-record user-session-pkg user-session)) + +(defmethod get-user-session-objects ((user-session-pkg user-session-pkg) (user-session user-session)) + (get-records user-session-pkg (make-instance 'user-session-object :user_session_id (id user-session)) "session_key ASC")) + +(defmethod get-user-session-object ((user-session-pkg user-session-pkg) session-key) + (when (and *sessionid* session-key) + (let ((user-session (get-user-session user-session-pkg))) + (when user-session + (get-record user-session-pkg (make-instance 'user-session-object :user_session_id (id user-session) :session_key session-key)))))) + +(defmethod flush-user-session-object ((user-session-pkg user-session-pkg) session-key) + (when (and *sessionid* session-key) + (let ((user-session-object (get-user-session-object user-session-pkg session-key))) + (when user-session-object + (delete-record user-session-pkg user-session-object))))) + +(defmethod create-user-session ((user-session-pkg user-session-pkg)) + (let* ((sessionid (org-ckons-session::generate-sessionid)) + (user-session (make-instance 'user-session :sessionid sessionid :datetime (get-universal-time)))) + (insert-record user-session-pkg user-session) + sessionid)) + +(defun get-session-object (session-key) + "Returns the object stored in the user session under the given +`session-key'." + (with-woodriverlessons-database + (let* ((user-session-pkg (make-instance 'user-session-pkg)) + (user-session-object (get-user-session-object user-session-pkg session-key)) + object) + (when user-session-object + (setf object (org-ckons-serializable::deserialize (serialization user-session-object))) + (setf (org-ckons-session::*session-key object) session-key)) + object))) + +(defun set-session-object (session-key object) + "Sets the object into the user-session under the given +`session-key'. Will not write anything if the session given by +`*sessionid*' does not exist." + (with-woodriverlessons-database + (let* ((user-session-pkg (make-instance 'user-session-pkg)) + (user-session-object (get-user-session-object user-session-pkg session-key))) + (if user-session-object + ;; overwrite existing session object with current serialization + (progn + (setf (serialization user-session-object) (org-ckons-serializable::serialize object :package-name (package-name #.*package*))) + (update-record user-session-pkg user-session-object)) + ;; insert a new object into the session + (let ((user-session (get-user-session user-session-pkg))) + (when user-session + (setf user-session-object (make-instance 'user-session-object + :user_session_id (id user-session) + :session_key session-key + :serialization (org-ckons-serializable::serialize object :package-name (package-name #.*package*)))) + (insert-record user-session-pkg user-session-object))))))) + +(defun flush-session-object (session-key) + "Removes the object from the user session under the given +`session-key'." + (with-woodriverlessons-database + (let ((user-session-pkg (make-instance 'user-session-pkg))) + (flush-user-session-object user-session-pkg *sessionid* session-key)))) + +(defun ensure-user-session-exists (&optional force-new-sessionid-p) + "Ensures that the user has a valid sessionid cookie. Returns the +`sessionid'. If the session does exist, update its timestamp." + (with-woodriverlessons-database + (let* ((user-session-pkg (make-instance 'user-session-pkg)) + (sessionid (when (not force-new-sessionid-p) + (org-ckons-session::get-sessionid-from-request))) + (user-session (get-user-session user-session-pkg sessionid))) + (if user-session + (update-timestamp user-session-pkg user-session) + (progn + (setf sessionid (create-user-session user-session-pkg)) + (org-ckons-session::set-sessionid-cookie *header-register* sessionid))) + sessionid))) + +(defun run-garbage-collect-cycle () + "Goes through all the user sessions, expiring any that have remained +inactive for a period of time determined by the `*session-timeout*' +variable." + (when (> (- (get-universal-time) org-ckons-session::*gc-last-cycle-timestamp*) org-ckons-session::*gc-interval*) + (setf org-ckons-session::*gc-last-cycle-timestamp* (get-universal-time)) + (with-woodriverlessons-database + (let ((user-session-pkg (make-instance 'user-session-pkg))) + (loop for user-session in (get-user-sessions user-session-pkg) do + (let ((inactive-time (- org-ckons-session::*gc-last-cycle-timestamp* (datetime user-session)))) + (when (and (> inactive-time org-ckons-session::*session-timeout*) + (sessionid user-session)) + (org-ckons-core::logger (format nil "Deleting expired session: id = [~a] ; sessionid = [~a]" (id user-session) (sessionid user-session))) + (loop for user-session-object in (get-user-session-objects user-session-pkg user-session) do + (delete-record user-session-pkg user-session-object)) + (delete-record user-session-pkg user-session)))))))) diff --git a/lisp/sql/user-session.lisp b/lisp/sql/user-session.lisp new file mode 100644 index 0000000..afaa28b --- /dev/null +++ b/lisp/sql/user-session.lisp @@ -0,0 +1,35 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :woodriverlessons) + +(defclass user-session (postgres-record) + ((id :initarg :id + :initform nil + :accessor id) + (sessionid :initarg :sessionid + :initform nil + :accessor sessionid) + (datetime :initarg :datetime + :initform nil + :accessor datetime) + (*table :initform "auth.user_sessions") + (*where-expression :initform "id = ~a")) + (:documentation "Holds the data for a auth.user_session record.")) + +(defclass user-session-object (postgres-record) + ((id :initarg :id + :initform nil + :accessor id) + (user_session_id :initarg :user_session_id + :initform nil + :accessor user_session_id) + (session_key :initarg :session_key + :initform nil + :accessor session_key) + (serialization :initarg :serialization + :initform nil + :accessor serialization) + (*table :initform "auth.user_session_objects") + (*where-expression :initform "id = ~a")) + (:documentation "Holds the data for a auth.user_session record.")) diff --git a/lisp/sql/user.lisp b/lisp/sql/user.lisp new file mode 100644 index 0000000..a181ff4 --- /dev/null +++ b/lisp/sql/user.lisp @@ -0,0 +1,50 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package :woodriverlessons) + +(defclass user (org-ckons-session::session-object postgres-record) + ((id :initarg :id + :initform nil + :accessor id) + (username :initarg :username + :initform nil + :accessor username) + (pwd :initarg :pwd + :initform nil + :accessor pwd) + (first_name :initarg :first_name + :initform nil + :accessor first_name) + (last_name :initarg :last_name + :initform nil + :accessor last_name) + (email :initarg :email + :initform nil + :accessor email) + (phone :initarg :phone + :initform nil + :accessor phone) + (active :initarg :active + :initform nil + :accessor active) + (created :initarg :created + :initform nil) + (*table :initform "auth.users") + (*where-expression :initform "id = ~a") + (org-ckons-session::*session-key :initform "user")) + (:documentation "Holds the data for a user record.")) + +(defmethod created ((user user)) + (slot-value user 'created)) + +(defmethod (setf created) (value (user user)) + (handler-case + (setf (slot-value user 'created) (simple-date-to-date value)) + (error (e) + (declare (ignore e)) + (setf (slot-value user 'created) nil)))) + +(defmethod sanitize-json ((user user)) + (setf (pwd user) nil) + (call-next-method)) -- cgit v1.3