db.lisp (13635B)
1 (in-package :miniblog.db) 2 3 (defclass blog-entries () 4 ((username :col-type (:varchar 64) 5 :accessor entry-username) 6 (last-updated-by :col-type (:varchar 64) 7 :accessor entry-last-updated-by) 8 (parent :col-type (or :bigint :null) 9 :accessor entry-parent) 10 (title :col-type (:varchar 200) 11 :accessor entry-title) 12 (content :col-type (:varchar 16384) 13 :accessor entry-content) 14 (rendered-content :col-type (or (:varchar 32768) :null) 15 :accessor entry-rendered-content) 16 (draftp :col-type :boolean 17 :accessor entry-draftp)) 18 (:metaclass mito:dao-table-class)) 19 20 (defclass blog-pages () 21 ((username :col-type (:varchar 64) 22 :accessor page-username) 23 (last-updated-by :col-type (:varchar 64) 24 :accessor page-last-updated-by) 25 (name :col-type (:varchar 64) 26 :accessor page-name) 27 (parent :col-type :bigint 28 :accessor page-parent) 29 (title :col-type (:varchar 200) 30 :accessor page-title) 31 (content :col-type (:varchar 16384) 32 :accessor page-content) 33 (rendered-content :col-type (or (:varchar 32768) :null) 34 :accessor page-rendered-content) 35 (draftp :col-type :boolean 36 :accessor page-draftp)) 37 (:metaclass mito:dao-table-class) 38 (:unique-keys (parent name))) 39 40 (defun init-tables () 41 "Initialize the DB schema. Verifies that tables exist and does necessary migrations." 42 (ensure-table-exists 'blog-entries) 43 (ensure-table-exists 'blog-pages) 44 (when (migration-expressions 'blog-entries) 45 (migrate-table 'blog-entries)) 46 (when (migration-expressions 'blog-pages) 47 (migrate-table 'blog-pages))) 48 49 (defun init (&rest params) 50 "Initialize the DB DAO. Consumes parameters identical to 51 mito:connect-toplevel or sxql:connect" 52 (apply #'connect-toplevel params) 53 (init-tables)) 54 55 (defun as-sql-bool (bool) 56 (if bool 57 t 58 'nil)) 59 60 (defun add-entry (title content &key rendered-content (username "nobody") parent (transform #'identity) draftp) 61 "Add a new blog entry to the database" 62 (funcall transform (create-dao 'blog-entries 63 :parent parent 64 :title title 65 :content content 66 :rendered-content rendered-content 67 :username username 68 :last-updated-by username 69 :draftp (as-sql-bool draftp)))) 70 71 (defun get-raw-entry (id) 72 (find-dao 'blog-entries :id id)) 73 74 (defun get-entry (id &key (transform #'identity)) 75 "Get entry by id, or nil if the requested id isn't found" 76 (let ((entry (get-raw-entry id))) 77 (if entry 78 (funcall transform entry)))) 79 80 (defun get-entries (&key year month max-entries (transform #'identity) drafts) 81 "Get entries from the database, optionally limited to a date 82 range or count" 83 (labels 84 ((curr-year () 85 (nth 5 (multiple-value-list (get-decoded-time)))) 86 87 (start-range (year month) 88 (format nil "~d-~2,'0d-~2,'0d" 89 (or year (curr-year)) 90 (or month 1) 91 1)) 92 93 (end-range (year month) 94 (let* ((working-year (or year (curr-year))) 95 (working-month (or month 12)) 96 (end-year 97 (if (eql working-month 12) 98 (+ working-year 1) 99 working-year)) 100 (end-month 101 (if (eql working-month 12) 102 1 103 (+ working-month 1)))) 104 (format nil "~d-~2,'0d-~2,'0d" end-year end-month 1))) 105 106 (where-clause (year month) 107 (let ((date-clauses (when (or year month) 108 `((:>= :created_at ,(start-range year month)) 109 (:< :created_at ,(end-range year month))))) 110 (drafts-clause (typecase drafts 111 ((eql :drafts-only) '((:= :draftp "true"))) 112 (null '((:= :draftp "false")))))) 113 (if (or date-clauses drafts-clause) 114 (where `(:and ,@date-clauses ,@drafts-clause 115 ,@(when (not (eql drafts :drafts-only)) 116 '((:or (:is-null :parent) (:= :parent 0)))))))))) 117 (let ((entries 118 (select-dao 'blog-entries 119 (where-clause year month) 120 (order-by (:desc :created_at)) 121 (if max-entries 122 (limit max-entries))))) 123 (get-subtree-for-entry 124 (loop for entry in entries 125 collect (mito.dao.mixin:object-id entry)) 126 :transform transform)))) 127 128 (defun get-subtree-for-entry (ids &key transform) 129 "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" 130 (labels ((convert-to-dao (record) 131 (apply #'mito.dao.mixin:make-dao-instance (cons 'blog-entries record)))) 132 (let* ((ids (etypecase ids 133 (number (list ids)) 134 (cons ids))) 135 (subentries 136 (mapcar #'convert-to-dao 137 (retrieve-by-sql 138 ; Construct the query by adding (LENGTH IDS) placeholders in the where clause 139 (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) 140 :binds ids)))) 141 (if transform 142 (mapcar transform subentries) 143 subentries)))) 144 145 (defun update-entry (id title content &key rendered-content parent (username "nobody") created-by (transform #'identity) draftp reset-timestamp-p) 146 "Update entry by id. Returns the updated entry or nil if the id doesn't exist." 147 (let ((entry (get-raw-entry id))) 148 (if entry 149 (funcall transform 150 (progn (setf (entry-title entry) title) 151 (setf (entry-content entry) content) 152 (setf (entry-rendered-content entry) rendered-content) 153 (setf (entry-parent entry) parent) 154 (setf (entry-last-updated-by entry) username) 155 (when created-by 156 (setf (entry-username entry) created-by)) 157 (setf (entry-draftp entry) (as-sql-bool draftp)) 158 (when reset-timestamp-p 159 (setf (mito.dao.mixin:object-created-at entry) (local-time:now))) ; FIXME: This is a horrible abuse of Mito 160 (save-dao entry) 161 entry))))) 162 163 (defun update-entry-rendered-content (id rendered-content &key (username "nobody") (transform #'identity)) 164 "Updated just the rendered content for an entry by ID. Returns the updated entry or NIL if ID doesn't exist." 165 (let ((entry (get-raw-entry id))) 166 (if entry 167 (funcall transform 168 (progn (setf (entry-rendered-content entry) rendered-content) 169 (setf (entry-last-updated-by entry) username) 170 (save-dao entry) 171 entry))))) 172 173 (defun delete-entry (id) 174 "Delete the specified entry from the database. No-op if the id is invalid." 175 (let ((entry (get-raw-entry id))) 176 (if entry 177 (delete-dao entry)))) 178 179 (defun add-page (name title content &key (parent 0) rendered-content (username "nobody") (transform #'identity) draftp) 180 "Add a new page to the database" 181 (funcall transform (create-dao 'blog-pages 182 :name name 183 :parent parent 184 :title title 185 :content content 186 :rendered-content rendered-content 187 :draftp (as-sql-bool draftp) 188 :username username 189 :last-updated-by username))) 190 191 (defun get-raw-page (id) 192 (find-dao 'blog-pages :id id)) 193 194 (defun get-page (id &key (transform #'identity)) 195 "Get page by id, or NIL if the requested id isn't found" 196 (let ((entry (get-raw-page id))) 197 (if entry 198 (funcall transform entry)))) 199 200 (defun build-tree-table (dao-list transform) 201 (let ((entry-table (make-hash-table))) 202 (labels ((build-tree (raw-entry) 203 (let ((id (mito.dao.mixin:object-id raw-entry)) 204 (parent-id (page-parent raw-entry)) 205 (entry (funcall transform raw-entry))) 206 (setf (getf entry :children) 207 (getf (gethash id entry-table) :children)) 208 (setf (gethash id entry-table) entry) 209 (setf (getf (gethash parent-id entry-table) :children) 210 (cons entry 211 (getf (gethash parent-id entry-table) :children)))))) 212 (mapcar #'build-tree dao-list) 213 entry-table))) 214 215 (defun get-pages (&key (root-id 0) (transform #'identity) drafts) 216 "Get all pages in a tree, or optionally a subtree starting from a given id. Returns the subtree as the first return value and the (unconditionally) full hashtable as the second." 217 (let* ((entry-table (build-tree-table 218 (typecase drafts 219 ((eql :drafts-only) (select-dao 'blog-pages 220 (where (:= :draftp "true")))) 221 (null (select-dao 'blog-pages 222 (where (:= :draftp "false")))) 223 (t (select-dao 'blog-pages))) 224 transform))) 225 (values (gethash root-id entry-table) entry-table))) 226 227 (defun update-page (id name title content &key rendered-content (username "nobody") (transform #'identity) draftp reset-timestamp-p) 228 "Update page by id. Returns the updated page or nil if the id doesn't exist." 229 (let ((entry (get-raw-page id))) 230 (if entry 231 (funcall transform 232 (progn (setf (page-name entry) name) 233 (setf (page-title entry) title) 234 (setf (page-content entry) content) 235 (setf (page-rendered-content entry) rendered-content) 236 (setf (page-last-updated-by entry) username) 237 (when reset-timestamp-p 238 (setf (mito.dao.mixin:object-created-at entry) (local-time:now))) ; FIXME: This is a horrible abuse of Mito 239 (setf (page-draftp entry) (as-sql-bool draftp)) 240 (save-dao entry) 241 entry))))) 242 243 (defun update-page-rendered-content (id rendered-content &key (username "nobody") (transform #'identity)) 244 "Updated just the rendered content for a page by ID. Returns the updated page or NIL if ID doesn't exist." 245 (let ((entry (get-raw-page id))) 246 (if entry 247 (funcall transform 248 (progn (setf (page-rendered-content entry) rendered-content) 249 (setf (page-last-updated-by entry) username) 250 (save-dao entry) 251 entry))))) 252 253 (defun move-page-dao (entry parent) 254 (setf (page-parent entry) parent) 255 (save-dao entry) 256 entry) 257 258 (defun move-page (id parent &key (transform #'identity)) 259 "Move a page under a new parent page (or to the root if parent is 0 or NIL)" 260 (let ((entry (get-raw-page id))) 261 (if entry 262 (funcall transform (move-page-dao entry (or parent 0)))))) 263 264 (defun prune-subtree (entry-table root &optional skip-top) 265 (if (not skip-top) 266 (delete-dao (getf root :dao))) 267 (mapcar #'(lambda (child) (prune-subtree entry-table child)) 268 (getf root :children))) 269 270 (defun delete-page (id &key (children :move-to-parent)) 271 "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." 272 (let* ((entry-table (build-tree-table (select-dao 'blog-pages) 273 (lambda (entry) (list :dao entry)))) 274 (entry (gethash id entry-table)) 275 (entry-dao (getf entry :dao)) 276 (entry-parent (if entry-dao (page-parent entry-dao))) 277 (entry-children (getf entry :children))) 278 (if entry-dao 279 (progn 280 (delete-dao entry-dao) 281 (ecase children 282 (:move-to-parent (mapcar #'(lambda (child) 283 (move-page-dao (getf child :dao) entry-parent)) 284 entry-children)) 285 (:move-to-root (mapcar #'(lambda (child) 286 (move-page-dao (getf child :dao) 0)) 287 entry-children)) 288 (:delete (prune-subtree entry-table entry t)))))))