|
|
|
(in-package #:cl-user)
|
|
|
|
(defpackage #:nera-db
|
|
|
|
(:nicknames #:nera)
|
|
|
|
(:use #:cl
|
|
|
|
#:app-constants
|
|
|
|
#:hermetic
|
|
|
|
#:ritherdon-archive.db
|
|
|
|
#:utils
|
|
|
|
#:user
|
|
|
|
#:pages
|
|
|
|
#:site-settings)
|
|
|
|
(:export #:init-db
|
|
|
|
#:update-user
|
|
|
|
#:get-user
|
|
|
|
#:get-user-id
|
|
|
|
#:delete-user
|
|
|
|
#:create-user
|
|
|
|
#:site-settings
|
|
|
|
#:migrate-all
|
|
|
|
#:get-all-users
|
|
|
|
#:update-enable-sign-on-settings
|
|
|
|
#:set-home-page
|
|
|
|
#:update-enable-site-logo-setting
|
|
|
|
#:update-site-name
|
|
|
|
#:create-page
|
|
|
|
#:update-page
|
|
|
|
#:get-page
|
|
|
|
#:delete-page
|
|
|
|
#:get-all-pages
|
|
|
|
#:nav-menu-slugs
|
|
|
|
#:update-nav-menu
|
|
|
|
#:system-data))
|
|
|
|
(in-package #:nera-db)
|
|
|
|
|
|
|
|
(defparameter *tables* '(user site-settings page)
|
|
|
|
"List of the DB tables that need to be checked for migrations and DB setup.")
|
|
|
|
|
|
|
|
(defun init-db (request)
|
|
|
|
"Creates the database and creates Admin. in `USER' table."
|
|
|
|
(destructuring-bind
|
|
|
|
(&key username display-name password allow-sign-up &allow-other-keys)
|
|
|
|
(utils:request-params request)
|
|
|
|
(with-connection (db)
|
|
|
|
;; Add to the list to add more tables.
|
|
|
|
(mapcar #'mito:ensure-table-exists *tables*)
|
|
|
|
(mito:create-dao 'user
|
|
|
|
:username username
|
|
|
|
:display-name display-name
|
|
|
|
:password (hermetic::hash password)
|
|
|
|
:administrator +true+)
|
|
|
|
(mito:create-dao 'site-settings
|
|
|
|
:enable-sign-up (utils:checkbox-to-bool allow-sign-up))
|
|
|
|
(mito:create-dao 'page
|
|
|
|
:title "Home"
|
|
|
|
:slug "home"
|
|
|
|
:enable-nav-menu +true+
|
|
|
|
:can-delete +true+)
|
|
|
|
(mito:create-dao 'page
|
|
|
|
:title "About"
|
|
|
|
:slug "about"
|
|
|
|
:enable-nav-menu +true+
|
|
|
|
:can-delete +true+)
|
|
|
|
(mito:create-dao 'page
|
|
|
|
:title "Contact"
|
|
|
|
:slug "contact"
|
|
|
|
:enable-nav-menu +true+
|
|
|
|
:can-delete +true+)
|
|
|
|
(mito:create-dao 'page
|
|
|
|
:title "Pages"
|
|
|
|
:slug "pages"
|
|
|
|
:enable-nav-menu +true+
|
|
|
|
:can-delete +false+)
|
|
|
|
(mito:create-dao 'page
|
|
|
|
:title "Archive"
|
|
|
|
:slug "archive"
|
|
|
|
:enable-nav-menu +true+
|
|
|
|
:can-delete +false+)
|
|
|
|
(mito:create-dao 'page
|
|
|
|
:title "Sign-Up"
|
|
|
|
:slug "sign-up"
|
|
|
|
:enable-nav-menu +true+
|
|
|
|
:can-delete +false+)
|
|
|
|
(mito:create-dao 'page
|
|
|
|
:title "Log-In"
|
|
|
|
:slug "login"
|
|
|
|
:enable-nav-menu +true+
|
|
|
|
:can-delete +false+))))
|
|
|
|
|
|
|
|
(defun ensure-tables-exist ()
|
|
|
|
"Creates missing tables from the database."
|
|
|
|
(with-connection (db)
|
|
|
|
(mapcar #'mito:ensure-table-exists *tables*)))
|
|
|
|
|
|
|
|
(defun migrate-all ()
|
|
|
|
"Migrate the tables after we changed the class definition."
|
|
|
|
(with-connection (db)
|
|
|
|
(ensure-tables-exist)
|
|
|
|
(mapcar #'mito:migrate-table *tables*)))
|
|
|
|
|
|
|
|
(defun create-user (username display-name password administrator)
|
|
|
|
"Add a new `USER' to the database."
|
|
|
|
(with-connection (db)
|
|
|
|
(mito:create-dao 'user
|
|
|
|
:username username
|
|
|
|
:display-name display-name
|
|
|
|
:administrator administrator
|
|
|
|
:password (hermetic::hash password))))
|
|
|
|
|
|
|
|
(defun delete-user (username)
|
|
|
|
"Deletes `USER' from the database."
|
|
|
|
(with-connection (db)
|
|
|
|
(mito:delete-by-values 'user:user :username username)))
|
|
|
|
|
|
|
|
(defun update-user (username &key display-name new-password)
|
|
|
|
"Updates `USER' in database."
|
|
|
|
(with-connection (db)
|
|
|
|
(let ((user-to-update
|
|
|
|
(mito:find-dao 'user:user :username username)))
|
|
|
|
(if (not (utils:string-is-nil-or-empty? display-name))
|
|
|
|
(setf (user::display-name-of user-to-update) display-name))
|
|
|
|
(if (not (utils:string-is-nil-or-empty? new-password))
|
|
|
|
(setf (user::password-of user-to-update) (hermetic::hash new-password)))
|
|
|
|
(mito:save-dao user-to-update))))
|
|
|
|
|
|
|
|
(defun get-user-id (username)
|
|
|
|
"Returns the Id. number of the specified `USERNAME' in the database."
|
|
|
|
(with-connection (db)
|
|
|
|
(mito:object-id
|
|
|
|
(mito:find-dao 'user :username username))))
|
|
|
|
|
|
|
|
(defun get-user (username)
|
|
|
|
"Returns a `USER' profile from the database."
|
|
|
|
(with-connection (db)
|
|
|
|
(mito:find-dao 'user :username username)))
|
|
|
|
|
|
|
|
(defun get-all-users ()
|
|
|
|
"Returns a list of all `USER' entries in the database."
|
|
|
|
(with-connection (db)
|
|
|
|
(mito:select-dao 'user
|
|
|
|
(sxql:order-by (:asc :display-name)))))
|
|
|
|
|
|
|
|
(defun get-page (slug)
|
|
|
|
"Returns a `PAGE' from the database."
|
|
|
|
(with-connection (db) (mito:find-dao 'page :slug slug)))
|
|
|
|
|
|
|
|
(defun get-all-pages ()
|
|
|
|
"Returns a list of all `PAGE' entries in the database."
|
|
|
|
(with-connection (db)
|
|
|
|
(mito:select-dao 'page
|
|
|
|
(sxql:order-by (:asc :slug)))))
|
|
|
|
|
|
|
|
(defun create-page (title slug nav-menu can-delete)
|
|
|
|
"Add a new `PAGE' to the database."
|
|
|
|
(with-connection (db)
|
|
|
|
(mito:create-dao 'page :title title :slug slug
|
|
|
|
:enable-nav-menu nav-menu :can-delete can-delete)))
|
|
|
|
|
|
|
|
(defun update-page (id title slug &optional nav-menu can-delete)
|
|
|
|
"Add a new `PAGE' to the database."
|
|
|
|
(with-connection (db)
|
|
|
|
(let ((page-to-update (mito:find-dao 'page :id id)))
|
|
|
|
(if (not (utils:string-is-nil-or-empty? title))
|
|
|
|
(setf (pages::title-of page-to-update) title))
|
|
|
|
(if (not (utils:string-is-nil-or-empty? slug))
|
|
|
|
(setf (pages::slug-of page-to-update) slug))
|
|
|
|
(if (not (null nav-menu))
|
|
|
|
(setf (pages::enable-nav-menu-p page-to-update) nav-menu))
|
|
|
|
(if (not (null can-delete))
|
|
|
|
(setf (pages::can-delete-p page-to-update) can-delete))
|
|
|
|
(mito:save-dao page-to-update))))
|
|
|
|
|
|
|
|
(defun delete-page (&key id slug)
|
|
|
|
"Delete `PAGE' from the database."
|
|
|
|
(with-connection (db)
|
|
|
|
(cond ((not slug)
|
|
|
|
(mito:delete-dao (mito:find-dao 'page :id id)))
|
|
|
|
((not id)
|
|
|
|
(mito:delete-dao (mito:find-dao 'page :slug slug)))
|
|
|
|
(t nil))))
|
|
|
|
|
|
|
|
(defun site-settings ()
|
|
|
|
"Gets the settings for the website from the database."
|
|
|
|
(with-connection (db)
|
|
|
|
(mito:find-dao 'site-settings)))
|
|
|
|
|
|
|
|
(defun update-enable-sign-on-settings (value)
|
|
|
|
"Updates the 'Enable Sign Up' setting in the database with `VALUE'."
|
|
|
|
(with-connection (db)
|
|
|
|
(let ((settings-to-update (mito:find-dao 'site-settings)))
|
|
|
|
(setf (site-settings::enable-sign-up-p settings-to-update)
|
|
|
|
(utils:checkbox-to-bool value))
|
|
|
|
(mito:save-dao settings-to-update))))
|
|
|
|
|
|
|
|
(defun update-enable-site-logo-setting (value)
|
|
|
|
"Updates the 'Enable Site Logo' setting in the database with `VALUE'."
|
|
|
|
(with-connection (db)
|
|
|
|
(let ((settings-to-update (mito:find-dao 'site-settings)))
|
|
|
|
(setf (site-settings::enable-site-logo-p settings-to-update)
|
|
|
|
(utils:checkbox-to-bool value))
|
|
|
|
(mito:save-dao settings-to-update))))
|
|
|
|
|
|
|
|
(defun set-home-page (value)
|
|
|
|
"Sets the page (in /storage/pages) to be displayed on the sites home page."
|
|
|
|
(with-connection (db)
|
|
|
|
(let ((settings-to-update (mito:find-dao 'site-settings)))
|
|
|
|
(setf (site-settings::home-page-of settings-to-update) value)
|
|
|
|
(mito:save-dao settings-to-update))))
|
|
|
|
|
|
|
|
(defun update-site-name (name)
|
|
|
|
"Updates the website's `SITE-NAME' the database."
|
|
|
|
(with-connection (db)
|
|
|
|
(let ((settings-to-update (mito:find-dao 'site-settings)))
|
|
|
|
(setf (site-settings::site-name-of settings-to-update) name)
|
|
|
|
(mito:save-dao settings-to-update))))
|
|
|
|
|
|
|
|
(defun update-nav-menu (page-slug value)
|
|
|
|
"Updates the `ENABLE-NAV-MENU' property in `PAGES' database."
|
|
|
|
(with-connection (db)
|
|
|
|
(let ((page-to-update (mito:find-dao 'page :slug page-slug)))
|
|
|
|
(setf (pages::enable-nav-menu-p page-to-update) value)
|
|
|
|
(mito:save-dao page-to-update))))
|
|
|
|
|
|
|
|
(defun nav-menu-slugs ()
|
|
|
|
(with-connection (db)
|
|
|
|
(mito:select-dao 'page
|
|
|
|
(sxql:where (:= :enable-nav-menu +true+)))))
|
|
|
|
|
|
|
|
(defun system-data ()
|
|
|
|
"Gets the website's settings and nav-menu from database."
|
|
|
|
(list (site-settings) (nav-menu-slugs)))
|