commit ec027131601a238a1e5b8cf58fb91ab1490036e1
parent 128941562d9ed8c2e1a5c2fa838c3c62b95e7cb9
Author: Decay <decay@todayiwilllaunchmyinfantsonintoorbit.com>
Date: Tue, 15 Sep 2020 13:17:37 -0700
DB support for pages
"Pages" are similar to posts but exist in a hierarchical tree off the
root and are not present in any of the dated blog post lists. Think
Wordpress (or... normal web pages really) and you won't be far off.
Diffstat:
2 files changed, 125 insertions(+), 3 deletions(-)
diff --git a/src/db.lisp b/src/db.lisp
@@ -11,10 +11,27 @@
:accessor entry-content))
(:metaclass mito:dao-table-class))
+(defclass blog-pages ()
+ ((username :col-type (:varchar 64)
+ :accessor page-username)
+ (last-updated-by :col-type (:varchar 64)
+ :accessor page-last-updated-by)
+ (name :col-type (:varchar 64)
+ :accessor page-name)
+ (parent :col-type :bigint
+ :accessor page-parent)
+ (title :col-type (:varchar 200)
+ :accessor page-title)
+ (content :col-type (:varchar 16384)
+ :accessor page-content))
+ (:metaclass mito:dao-table-class)
+ (:unique-keys (parent name)))
+
(defun init-tables ()
"Initialize the DB schema. Currently just does the mito
yakshaving to create the BLOG-ENTRIES table."
- (ensure-table-exists 'blog-entries))
+ (ensure-table-exists 'blog-entries)
+ (ensure-table-exists 'blog-pages))
(defun init (&rest params)
"Initialize the DB DAO. Consumes parameters identical to
@@ -22,7 +39,10 @@
(apply #'connect-toplevel params)
(init-tables))
-(defun xform (entry)
+(defgeneric xform (entry)
+ (:documentation "Transform an entry of some type into an idiomatic p-list"))
+
+(defmethod xform ((entry blog-entries))
"Transform a blog-entries object into an idiomatic property list"
(list :id (mito.dao.mixin:object-id entry)
:created-at (mito.dao.mixin:object-created-at entry)
@@ -32,6 +52,18 @@
:created-by (entry-username entry)
:last-updated-by (entry-last-updated-by entry)))
+(defmethod xform ((entry blog-pages))
+ "Transform a blog-pages object into an idiomatic p-list"
+ (list :id (mito.dao.mixin:object-id entry)
+ :created-at (mito.dao.mixin:object-created-at entry)
+ :last-updated-at (mito.dao.mixin:object-updated-at entry)
+ :name (page-name entry)
+ :parent (page-parent entry)
+ :title (page-title entry)
+ :content (page-content entry)
+ :created-by (page-username entry)
+ :last-updated-by (page-last-updated-by entry)))
+
(defun add-entry (title content &key (username "nobody"))
"Add a new blog entry to the database"
(xform (create-dao 'blog-entries
@@ -112,3 +144,91 @@
(let ((entry (get-raw-entry id)))
(if entry
(delete-dao entry))))
+
+(defun add-page (name title content &key (parent 0) (username "nobody"))
+ "Add a new page to the database"
+ (xform (create-dao 'blog-pages
+ :name name
+ :parent parent
+ :title title
+ :content content
+ :username username
+ :last-updated-by username)))
+
+(defun get-raw-page (id)
+ (find-dao 'blog-pages :id id))
+
+(defun get-page (id)
+ "Get page by id, or NIL if the requested id isn't found"
+ (let ((entry (get-raw-page id)))
+ (if entry
+ (xform entry))))
+
+(defun build-tree-table (dao-list &optional (xform #'xform))
+ (let ((entry-table (make-hash-table)))
+ (labels ((build-tree (raw-entry)
+ (let ((id (mito.dao.mixin:object-id raw-entry))
+ (parent-id (page-parent raw-entry))
+ (entry (funcall xform raw-entry)))
+ (setf (getf entry :children)
+ (getf (gethash id entry-table) :children))
+ (setf (gethash id entry-table) entry)
+ (setf (getf (gethash parent-id entry-table) :children)
+ (cons entry
+ (getf (gethash parent-id entry-table) :children))))))
+ (mapcar #'build-tree dao-list)
+ entry-table)))
+
+(defun get-pages (&optional (root-id 0))
+ "Get all pages in a tree, or optionally a subtree starting from a given id"
+ (let* ((entry-table (build-tree-table (select-dao 'blog-pages))))
+ (gethash root-id entry-table)))
+
+(defun update-page (id name title content &key (username "nobody"))
+ "Update page by id. Returns the updated page or nil if the id doesn't exist."
+ (let ((entry (get-raw-page id)))
+ (if entry
+ (xform (progn
+ (setf (page-name entry) name)
+ (setf (page-title entry) title)
+ (setf (page-content entry) content)
+ (setf (page-last-updated-by entry) username)
+ (save-dao entry)
+ entry)))))
+
+(defun move-page-dao (entry parent)
+ (setf (page-parent entry) parent)
+ (save-dao entry)
+ entry)
+
+(defun move-page (id parent)
+ "Move a page under a new parent page (or to the root if parent is 0 or NIL)"
+ (let ((entry (get-raw-page id)))
+ (if entry
+ (xform (move-page-dao entry (or parent 0))))))
+
+(defun prune-subtree (entry-table root &optional skip-top)
+ (if (not skip-top)
+ (delete-dao (getf root :dao)))
+ (mapcar #'(lambda (child) (prune-subtree entry-table child))
+ (getf root :children)))
+
+(defun delete-page (id &key (children :move-to-parent))
+ "Delete a page. The parameter CHILDREN can be any of :MOVE-TO-PARENT (the default) in which all immediate children will be attached to the deleted page's parent, :MOVE-TO-ROOT in which all immediate children will be made top-level pages, or :DELETE in which case the entire subtree will be pruned."
+ (let* ((entry-table (build-tree-table (select-dao 'blog-pages)
+ (lambda (entry) (list :dao entry))))
+ (entry (gethash id entry-table))
+ (entry-dao (getf entry :dao))
+ (entry-parent (if entry-dao (page-parent entry-dao)))
+ (entry-children (getf entry :children)))
+ (if entry-dao
+ (progn
+ (delete-dao entry-dao)
+ (ecase children
+ (:move-to-parent (mapcar #'(lambda (child)
+ (move-page-dao (getf child :dao) entry-parent))
+ entry-children))
+ (:move-to-root (mapcar #'(lambda (child)
+ (move-page-dao (getf child :dao) 0))
+ entry-children))
+ (:delete (prune-subtree entry-table entry t)))))))
diff --git a/src/packages.lisp b/src/packages.lisp
@@ -15,7 +15,9 @@
(:use :cl :mito :sxql)
(:export #:init #:init-tables #:add-entry #:get-entry
#:with-entry-id
- #:get-entries #:update-entry #:delete-entry))
+ #:get-entries #:update-entry #:delete-entry
+ #:add-page #:get-page #:get-pages #:update-page
+ #:delete-page))
(defpackage :miniblog.content
(:use :cl :local-time :cl-emb :str)
