db.lisp (13290B)
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") (transform #'identity) draftp) 61 "Add a new blog entry to the database" 62 (funcall transform (create-dao 'blog-entries 63 :title title 64 :content content 65 :rendered-content rendered-content 66 :username username 67 :last-updated-by username 68 :draftp (as-sql-bool draftp)))) 69 70 (defun get-raw-entry (id) 71 (find-dao 'blog-entries :id id)) 72 73 (defun get-entry (id &key (transform #'identity)) 74 "Get entry by id, or nil if the requested id isn't found" 75 (let ((entry (get-raw-entry id))) 76 (if entry 77 (funcall transform entry)))) 78 79 (defun get-entries (&key year month max-entries (transform #'identity) drafts) 80 "Get entries from the database, optionally limited to a date 81 range or count" 82 (labels 83 ((curr-year () 84 (nth 5 (multiple-value-list (get-decoded-time)))) 85 86 (start-range (year month) 87 (format nil "~d-~2,'0d-~2,'0d" 88 (or year (curr-year)) 89 (or month 1) 90 1)) 91 92 (end-range (year month) 93 (let* ((working-year (or year (curr-year))) 94 (working-month (or month 12)) 95 (end-year 96 (if (eql working-month 12) 97 (+ working-year 1) 98 working-year)) 99 (end-month 100 (if (eql working-month 12) 101 1 102 (+ working-month 1)))) 103 (format nil "~d-~2,'0d-~2,'0d" end-year end-month 1))) 104 105 (where-clause (year month) 106 (let ((date-clauses (when (or year month) 107 `((:>= :created_at ,(start-range year month)) 108 (:< :created_at ,(end-range year month))))) 109 (drafts-clause (typecase drafts 110 ((eql :drafts-only) '((:= :draftp "true"))) 111 (null '((:= :draftp "false")))))) 112 (if (or date-clauses drafts-clause) 113 (where `(:and ,@date-clauses ,@drafts-clause (:or (:is-null :parent) (:= :parent 0)))))))) 114 (let ((entries 115 (select-dao 'blog-entries 116 (where-clause year month) 117 (order-by (:desc :created_at)) 118 (if max-entries 119 (limit max-entries))))) 120 (get-subtree-for-entry 121 (loop for entry in entries 122 collect (mito.dao.mixin:object-id entry)) 123 :transform transform)))) 124 125 (defun get-subtree-for-entry (ids &key transform) 126 "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" 127 (labels ((convert-to-dao (record) 128 (apply #'mito.dao.mixin:make-dao-instance (cons 'blog-entries record)))) 129 (let* ((ids (etypecase ids 130 (number (list ids)) 131 (cons ids))) 132 (subentries 133 (mapcar #'convert-to-dao 134 (retrieve-by-sql 135 ; Construct the query by adding (LENGTH IDS) placeholders in the where clause 136 (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) 137 :binds ids)))) 138 (if transform 139 (mapcar transform subentries) 140 subentries)))) 141 142 (defun update-entry (id title content &key rendered-content (username "nobody") (transform #'identity) draftp reset-timestamp-p) 143 "Update entry by id. Returns the updated entry or nil if the id doesn't exist." 144 (let ((entry (get-raw-entry id))) 145 (if entry 146 (funcall transform 147 (progn (setf (entry-title entry) title) 148 (setf (entry-content entry) content) 149 (setf (entry-rendered-content entry) rendered-content) 150 (setf (entry-last-updated-by entry) username) 151 (setf (entry-draftp entry) (as-sql-bool draftp)) 152 (when reset-timestamp-p 153 (setf (mito.dao.mixin:object-created-at entry) (local-time:now))) ; FIXME: This is a horrible abuse of Mito 154 (save-dao entry) 155 entry))))) 156 157 (defun update-entry-rendered-content (id rendered-content &key (username "nobody") (transform #'identity)) 158 "Updated just the rendered content for an entry by ID. Returns the updated entry or NIL if ID doesn't exist." 159 (let ((entry (get-raw-entry id))) 160 (if entry 161 (funcall transform 162 (progn (setf (entry-rendered-content entry) rendered-content) 163 (setf (entry-last-updated-by entry) username) 164 (save-dao entry) 165 entry))))) 166 167 (defun delete-entry (id) 168 "Delete the specified entry from the database. No-op if the id is invalid." 169 (let ((entry (get-raw-entry id))) 170 (if entry 171 (delete-dao entry)))) 172 173 (defun add-page (name title content &key (parent 0) rendered-content (username "nobody") (transform #'identity) draftp) 174 "Add a new page to the database" 175 (funcall transform (create-dao 'blog-pages 176 :name name 177 :parent parent 178 :title title 179 :content content 180 :rendered-content rendered-content 181 :draftp (as-sql-bool draftp) 182 :username username 183 :last-updated-by username))) 184 185 (defun get-raw-page (id) 186 (find-dao 'blog-pages :id id)) 187 188 (defun get-page (id &key (transform #'identity)) 189 "Get page by id, or NIL if the requested id isn't found" 190 (let ((entry (get-raw-page id))) 191 (if entry 192 (funcall transform entry)))) 193 194 (defun build-tree-table (dao-list transform) 195 (let ((entry-table (make-hash-table))) 196 (labels ((build-tree (raw-entry) 197 (let ((id (mito.dao.mixin:object-id raw-entry)) 198 (parent-id (page-parent raw-entry)) 199 (entry (funcall transform raw-entry))) 200 (setf (getf entry :children) 201 (getf (gethash id entry-table) :children)) 202 (setf (gethash id entry-table) entry) 203 (setf (getf (gethash parent-id entry-table) :children) 204 (cons entry 205 (getf (gethash parent-id entry-table) :children)))))) 206 (mapcar #'build-tree dao-list) 207 entry-table))) 208 209 (defun get-pages (&key (root-id 0) (transform #'identity) drafts) 210 "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." 211 (let* ((entry-table (build-tree-table 212 (typecase drafts 213 ((eql :drafts-only) (select-dao 'blog-pages 214 (where (:= :draftp "true")))) 215 (null (select-dao 'blog-pages 216 (where (:= :draftp "false")))) 217 (t (select-dao 'blog-pages))) 218 transform))) 219 (values (gethash root-id entry-table) entry-table))) 220 221 (defun update-page (id name title content &key rendered-content (username "nobody") (transform #'identity) draftp reset-timestamp-p) 222 "Update page by id. Returns the updated page or nil if the id doesn't exist." 223 (let ((entry (get-raw-page id))) 224 (if entry 225 (funcall transform 226 (progn (setf (page-name entry) name) 227 (setf (page-title entry) title) 228 (setf (page-content entry) content) 229 (setf (page-rendered-content entry) rendered-content) 230 (setf (page-last-updated-by entry) username) 231 (when reset-timestamp-p 232 (setf (mito.dao.mixin:object-created-at entry) (local-time:now))) ; FIXME: This is a horrible abuse of Mito 233 (setf (page-draftp entry) (as-sql-bool draftp)) 234 (save-dao entry) 235 entry))))) 236 237 (defun update-page-rendered-content (id rendered-content &key (username "nobody") (transform #'identity)) 238 "Updated just the rendered content for a page by ID. Returns the updated page or NIL if ID doesn't exist." 239 (let ((entry (get-raw-page id))) 240 (if entry 241 (funcall transform 242 (progn (setf (page-rendered-content entry) rendered-content) 243 (setf (page-last-updated-by entry) username) 244 (save-dao entry) 245 entry))))) 246 247 (defun move-page-dao (entry parent) 248 (setf (page-parent entry) parent) 249 (save-dao entry) 250 entry) 251 252 (defun move-page (id parent &key (transform #'identity)) 253 "Move a page under a new parent page (or to the root if parent is 0 or NIL)" 254 (let ((entry (get-raw-page id))) 255 (if entry 256 (funcall transform (move-page-dao entry (or parent 0)))))) 257 258 (defun prune-subtree (entry-table root &optional skip-top) 259 (if (not skip-top) 260 (delete-dao (getf root :dao))) 261 (mapcar #'(lambda (child) (prune-subtree entry-table child)) 262 (getf root :children))) 263 264 (defun delete-page (id &key (children :move-to-parent)) 265 "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." 266 (let* ((entry-table (build-tree-table (select-dao 'blog-pages) 267 (lambda (entry) (list :dao entry)))) 268 (entry (gethash id entry-table)) 269 (entry-dao (getf entry :dao)) 270 (entry-parent (if entry-dao (page-parent entry-dao))) 271 (entry-children (getf entry :children))) 272 (if entry-dao 273 (progn 274 (delete-dao entry-dao) 275 (ecase children 276 (:move-to-parent (mapcar #'(lambda (child) 277 (move-page-dao (getf child :dao) entry-parent)) 278 entry-children)) 279 (:move-to-root (mapcar #'(lambda (child) 280 (move-page-dao (getf child :dao) 0)) 281 entry-children)) 282 (:delete (prune-subtree entry-table entry t)))))))