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