Public archive for the Return to Ritherdon project.
https://www.nicolaellisandritherdon.com
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
369 lines
12 KiB
369 lines
12 KiB
(in-package #:cl-user) |
|
(defpackage #:nera-db |
|
(:nicknames #:nera) |
|
(:use #:cl |
|
#:app-constants |
|
#:hermetic |
|
#:ritherdon-archive.db |
|
#:utils |
|
#:user |
|
#:pages |
|
#:files |
|
#:site-settings |
|
#:archive) |
|
(:export #:init-db |
|
#:update-user |
|
#:get-user |
|
#:get-user-id |
|
#:delete-user |
|
#:create-user |
|
#:get-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 |
|
#:add-storage-file |
|
#:get-storage-file |
|
#:get-all-storage-files |
|
#:rename-storage-file |
|
#:delete-storage-file |
|
#:get-all-archive-entries |
|
#:create-archive-entry |
|
#:get-archive-entry |
|
#:delete-archive-entry |
|
#:update-archive-entry-property |
|
#:latest-archive-editted-entries |
|
#:latest-editted-pages |
|
#:latest-storage-editted-files)) |
|
(in-package #:nera-db) |
|
|
|
(defparameter *tables* '(user site-settings page storage-file archive-entry) |
|
"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 latest-editted-pages (amount &optional reverse) |
|
"Gets the latest `AMOUNT' of edited entries from the database. |
|
`REVERSE' is an optional parameter which puts the most recently |
|
editted article entry as the first item in the list.." |
|
(with-connection (db) |
|
(mito:select-dao 'pages:page |
|
(sxql:limit amount) |
|
(if reverse |
|
(sxql:order-by (:desc 'pages::updated-at)) |
|
(sxql:order-by 'pages::updated-at))))) |
|
|
|
(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 get-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 (selected-pages) |
|
"Updates the `ENABLE-NAV-MENU' property in `PAGE' database." |
|
(loop for page in selected-pages |
|
do (with-connection (db) |
|
(let ((page-to-update (mito:find-dao 'page :slug (car page)))) |
|
(setf (pages::enable-nav-menu-p page-to-update) |
|
(utils:checkbox-to-bool (cdr page))) |
|
(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 (get-site-settings) (nav-menu-slugs))) |
|
|
|
(defun add-storage-file (filename slug file-type) |
|
"Add a row to the 'storage_file' table in the database." |
|
(with-connection (db) |
|
(mito:create-dao 'storage-file |
|
:name filename |
|
:slug slug |
|
:file-type file-type))) |
|
|
|
(defun get-storage-file (&key filename slug) |
|
"Returns a `STORAGE-FILE' row from the database. `NIL' if nothing found." |
|
(with-connection (db) |
|
(if (null slug) |
|
(mito:find-dao 'files:storage-file :name filename) |
|
(mito:find-dao 'files:storage-file :slug slug)))) |
|
|
|
(defun latest-storage-editted-files (amount &optional reverse) |
|
"Gets the latest `AMOUNT' of edited entries from the database. |
|
`REVERSE' is an optional parameter which puts the most recently |
|
editted article entry as the first item in the list.." |
|
(with-connection (db) |
|
(mito:select-dao 'storage-file |
|
(sxql:limit amount) |
|
(if reverse |
|
(sxql:order-by (:desc 'storage::updated-at)) |
|
(sxql:order-by 'storage::updated-at))))) |
|
|
|
(defun get-all-storage-files () |
|
"Returns a list of all `STORAGE-FILES' entries in the database." |
|
(with-connection (db) |
|
(mito:select-dao 'storage-file |
|
(sxql:order-by (:asc :name))))) |
|
|
|
(defun rename-storage-file (old-file-name new-file-name) |
|
"Renames `STORAGE-FILE' in the database. |
|
The `NAME' is renamed from `OLD-FILE-NAME' to `NEW-FILE-NAME' and the |
|
slug is updated based on `NEW-FILE-NAME'." |
|
(with-connection (db) |
|
(let ((file-to-rename (mito:find-dao 'storage-file :name old-file-name))) |
|
(setf (files::name-of file-to-rename) new-file-name |
|
(files::slug-of file-to-rename) (utils:slugify new-file-name)) |
|
(mito:save-dao file-to-rename)))) |
|
|
|
(defun delete-storage-file (&key name slug) |
|
"Delete `STORAGE-FILE' from database." |
|
(with-connection (db) |
|
(if (null slug) |
|
(mito:delete-by-values 'files:storage-file :name name) |
|
(mito:delete-by-values 'files:storage-file :slug slug)))) |
|
|
|
(defun get-all-archive-entries () |
|
"Returns a list of all `ARCHIVE-ENTRY' entries in the database." |
|
(with-connection (db) |
|
(mito:select-dao 'archive:archive-entry |
|
(sxql:order-by (:asc :title))))) |
|
|
|
(defun create-archive-entry |
|
(title search-id slug thumbnail-slug thumbnail-file-type keywords) |
|
"Add a new `ARCHIVE-ENTRY' to the database." |
|
(with-connection (db) |
|
(mito:create-dao 'archive:archive-entry |
|
:title title |
|
:search-id search-id |
|
:slug slug |
|
:thumbnail-slug thumbnail-slug |
|
:thumbnail-file-type thumbnail-file-type |
|
:keywords keywords))) |
|
|
|
(defun get-archive-entry (&key id title slug) |
|
"Returns a `ARCHIVE-ENTRY' from the database." |
|
(with-connection (db) |
|
(cond ((and (not title) (not slug)) |
|
(mito:find-dao 'archive:archive-entry :id id)) |
|
((and (not id) (not slug)) |
|
(mito:find-dao 'archive:archive-entry :title title)) |
|
((and (not id) (not title)) |
|
(mito:find-dao 'archive:archive-entry :slug slug)) |
|
(t nil)))) |
|
|
|
(defun latest-archive-editted-entries (amount &optional reverse) |
|
"Gets the latest `AMOUNT' of edited entries from the database. |
|
`REVERSE' is an optional parameter which puts the most recently |
|
editted article entry as the first item in the list.." |
|
(with-connection (db) |
|
(mito:select-dao 'archive:archive-entry |
|
(sxql:limit amount) |
|
(if reverse |
|
(sxql:order-by (:desc 'archive::updated-at)) |
|
(sxql:order-by 'archive::updated-at))))) |
|
|
|
(defun update-archive-entry-property (&key slug property value) |
|
"Updates an `ARCHIVE-ENTRY' entry in database. |
|
An example of how to use this function is as follows (remove back-slashes): |
|
|
|
(nera:update-archive-entry-property |
|
:slug \"edit-archive-test.html\" |
|
:propery 'archive::keywords-of |
|
:value \"test,image\")" |
|
(with-connection (db) |
|
(let ((entry-to-update |
|
(mito:find-dao 'archive:archive-entry :slug slug))) |
|
(eval `(setf (,property ,entry-to-update) ,value)) |
|
(mito:save-dao entry-to-update)))) |
|
|
|
(defun delete-archive-entry (&key id slug) |
|
"Delete `ARCHIVE-ENTRY' from the database." |
|
(with-connection (db) |
|
(cond ((not slug) |
|
(mito:delete-dao (mito:find-dao 'archive:archive-entry :id id))) |
|
((not id) |
|
(mito:delete-dao (mito:find-dao 'archive:archive-entry :slug slug))))))
|
|
|