commit 378c05b0d7b7dd1c9c9bf3ea296db9bb3019070a
parent 4b210b7b5beccddf110bd2890f633852cfddb51b
Author: Decay <decay@todayiwilllaunchmyinfantsonintoorbit.com>
Date: Sat, 2 Nov 2024 14:06:57 -0700
Initial support for genericizing posts
We're adding a tree structure to posts similar to pages (and with a more
efficient traversal method!) that will allow simplifying the schema and
supporting multiple different taxonomies other than just posts and
pages. Next steps will involve automatic migrations; for now you will
want to run:
(let ((mito:*connection* (apply #'dbi:connect-cached miniblog:*db-config*)))
(mito:migrate-table 'miniblog.db:blog-entries))
Will be adding automigration in a future commit.
Diffstat:
3 files changed, 69 insertions(+), 19 deletions(-)
diff --git a/src/data.lisp b/src/data.lisp
@@ -26,6 +26,7 @@
(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)
+ :parent (entry-parent entry)
:title (entry-title entry)
:content (entry-content entry)
:rendered-content (entry-rendered-content entry)
@@ -52,9 +53,35 @@
(defun add-entry (title content &key rendered-content (username "nobody") draftp)
(miniblog.db:add-entry title content :rendered-content rendered-content :draftp draftp :username username :transform #'xform))
+(defun make-entry-tree (id subtree)
+ (let ((dict (make-hash-table)))
+ (flet ((attach-node (node)
+ (let* ((node-id (getf node :id))
+ (parent-id (or (getf node :parent) 0))
+ (curr-node (gethash node-id dict))
+ (parent-node (gethash parent-id dict))
+ (siblings (getf parent-node :children)))
+ (if (and curr-node (getf curr-node :children) (getf node :children))
+ (progn
+ (format t "womp womp ~A~%" (getf node :children))
+ (rplaca (getf node :children) (getf curr-node :children)))
+ (setf (getf node :children) (list)))
+ (setf (getf parent-node :children) (cons node siblings))
+ (setf (gethash parent-id dict) parent-node)
+ (setf (gethash node-id dict) node))))
+ (loop for node in subtree
+ do (attach-node node))
+ (let ((root (gethash id dict)))
+ (if (getf root :id)
+ ; Real node, return as root
+ root
+ ; Nonexistent node (probably 0), return the list of first-level children instead
+ (getf root :children))))))
+
(defun get-entry (id)
"Get entry by id, or nil if the requested id isn't found"
- (miniblog.db:get-entry id :transform #'xform))
+ (let ((subtree (miniblog.db:get-subtree-for-entry id :transform #'xform)))
+ (make-entry-tree id subtree)))
(defmacro with-entry-id (entry id &rest body)
"Takes a varname to hold the entry list and a post id
@@ -74,7 +101,7 @@
(defun get-entries (&key year month max-entries include-drafts-p)
"Get entries from the database, optionally limited to a date
range or count"
- (miniblog.db:get-entries :year year :month month :drafts include-drafts-p :max-entries max-entries :transform #'xform))
+ (make-entry-tree 0 (miniblog.db:get-entries :year year :month month :drafts include-drafts-p :max-entries max-entries :transform #'xform)))
(defun update-entry (id title content &key rendered-content (username "nobody") draftp reset-timestamp-p)
"Update entry by id. Returns the updated entry or nil if the id doesn't exist."
diff --git a/src/db.lisp b/src/db.lisp
@@ -5,6 +5,8 @@
:accessor entry-username)
(last-updated-by :col-type (:varchar 64)
:accessor entry-last-updated-by)
+ (parent :col-type (or :bigint :null)
+ :accessor entry-parent)
(title :col-type (:varchar 200)
:accessor entry-title)
(content :col-type (:varchar 16384)
@@ -105,29 +107,49 @@
((eql :drafts-only) '((:= :draftp "true")))
(null '((:= :draftp "false"))))))
(if (or date-clauses drafts-clause)
- (where `(:and ,@date-clauses ,@drafts-clause))))))
-
- (mapcar transform
+ (where `(:and ,@date-clauses ,@drafts-clause (:or (:is-null :parent) (:= :parent 0))))))))
+ (let ((entries
(select-dao 'blog-entries
(where-clause year month)
(order-by (:desc :created_at))
(if max-entries
- (limit max-entries))))))
+ (limit max-entries)))))
+ (get-subtree-for-entry
+ (loop for entry in entries
+ collect (mito.dao.mixin:object-id entry))
+ :transform transform))))
+
+(defun get-subtree-for-entry (ids &key transform)
+ "Fetches all posts dependent on post(s) IDS via recursive CTE. Since we use handhacked SQL here there may be compatibility issues for databases with weak support for recursive CTEs; this has been verified as functional at least in mysql, sqlite and postgres"
+ (labels ((convert-to-dao (record)
+ (apply #'mito.dao.mixin:make-dao-instance (cons 'blog-entries record))))
+ (let* ((ids (etypecase ids
+ (number (list ids))
+ (cons ids)))
+ (subentries
+ (mapcar #'convert-to-dao
+ (retrieve-by-sql
+ ; Construct the query by adding (LENGTH IDS) placeholders in the where clause
+ (format nil "with recursive posttree (id,username,last_updated_by,title,content,created_at,updated_at,rendered_content,draftp,parent) as (select e.id,e.username,e.last_updated_by,e.title,e.content,e.created_at,e.updated_at,e.rendered_content,e.draftp,e.parent from blog_entries as e where e.id in (~{?~*~^,~}) union all select e.id,e.username,e.last_updated_by,e.title,e.content,e.created_at,e.updated_at,e.rendered_content,e.draftp,e.parent from blog_entries as e inner join posttree as d on e.parent = d.id) select id,username,last_updated_by,title,content,created_at,updated_at,rendered_content,draftp,parent from posttree order by created_at" ids)
+ :binds ids))))
+ (if transform
+ (mapcar transform subentries)
+ subentries))))
(defun update-entry (id title content &key rendered-content (username "nobody") (transform #'identity) draftp reset-timestamp-p)
"Update entry by id. Returns the updated entry or nil if the id doesn't exist."
(let ((entry (get-raw-entry id)))
(if entry
- (funcall transform
- (progn (setf (entry-title entry) title)
- (setf (entry-content entry) content)
- (setf (entry-rendered-content entry) rendered-content)
- (setf (entry-last-updated-by entry) username)
- (setf (entry-draftp entry) (as-sql-bool draftp))
- (when reset-timestamp-p
- (setf (mito.dao.mixin:object-created-at entry) (local-time:now))) ; FIXME: This is a horrible abuse of Mito
- (save-dao entry)
- entry)))))
+ (funcall transform
+ (progn (setf (entry-title entry) title)
+ (setf (entry-content entry) content)
+ (setf (entry-rendered-content entry) rendered-content)
+ (setf (entry-last-updated-by entry) username)
+ (setf (entry-draftp entry) (as-sql-bool draftp))
+ (when reset-timestamp-p
+ (setf (mito.dao.mixin:object-created-at entry) (local-time:now))) ; FIXME: This is a horrible abuse of Mito
+ (save-dao entry)
+ entry)))))
(defun update-entry-rendered-content (id rendered-content &key (username "nobody") (transform #'identity))
"Updated just the rendered content for an entry by ID. Returns the updated entry or NIL if ID doesn't exist."
diff --git a/src/packages.lisp b/src/packages.lisp
@@ -21,12 +21,13 @@
(defpackage :miniblog.db
(:use :cl :mito :sxql)
(:export #:blog-entries #:blog-pages
- #:entry-username #:entry-last-updated-by #:entry-title #:entry-content
- #:entry-rendered-content #:entry-draftp
+ #:entry-username #:entry-last-updated-by #:entry-parent #:entry-title
+ #:entry-content #:entry-rendered-content #:entry-draftp
#:page-username #:page-last-updated-by #:page-name #:page-parent
#:page-title #:page-content #:page-rendered-content #:page-draftp
#:init #:init-tables #:add-entry #:get-entry
#:get-entries #:update-entry #:update-entry-rendered-content #:delete-entry
+ #:get-subtree-for-entry
#:add-page #:get-page
#:get-pages #:update-page #:update-page-rendered-content #:delete-page
#:move-page))
@@ -34,7 +35,7 @@
(defpackage :miniblog.data
(:use :cl)
(:import-from :miniblog.db :blog-entries :blog-pages
- :entry-username :entry-last-updated-by :entry-title
+ :entry-username :entry-last-updated-by :entry-parent :entry-title
:entry-content :entry-rendered-content :entry-draftp
:page-username :page-last-updated-by :page-name :page-parent
:page-title :page-content :page-rendered-content :page-draftp)
