db.lisp (8094B)
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 (:metaclass mito:dao-table-class)) 13 14 (defclass blog-pages () 15 ((username :col-type (:varchar 64) 16 :accessor page-username) 17 (last-updated-by :col-type (:varchar 64) 18 :accessor page-last-updated-by) 19 (name :col-type (:varchar 64) 20 :accessor page-name) 21 (parent :col-type :bigint 22 :accessor page-parent) 23 (title :col-type (:varchar 200) 24 :accessor page-title) 25 (content :col-type (:varchar 16384) 26 :accessor page-content)) 27 (:metaclass mito:dao-table-class) 28 (:unique-keys (parent name))) 29 30 (defun init-tables () 31 "Initialize the DB schema. Currently just does the mito 32 yakshaving to create the BLOG-ENTRIES table." 33 (ensure-table-exists 'blog-entries) 34 (ensure-table-exists 'blog-pages)) 35 36 (defun init (&rest params) 37 "Initialize the DB DAO. Consumes parameters identical to 38 mito:connect-toplevel or sxql:connect" 39 (apply #'connect-toplevel params) 40 (init-tables)) 41 42 (defun add-entry (title content &key (username "nobody") (transform #'identity)) 43 "Add a new blog entry to the database" 44 (funcall transform (create-dao 'blog-entries 45 :title title 46 :content content 47 :username username 48 :last-updated-by username))) 49 50 (defun get-raw-entry (id) 51 (find-dao 'blog-entries :id id)) 52 53 (defun get-entry (id &key (transform #'identity)) 54 "Get entry by id, or nil if the requested id isn't found" 55 (let ((entry (get-raw-entry id))) 56 (if entry 57 (funcall transform entry)))) 58 59 (defun get-entries (&key year month max-entries (transform #'identity)) 60 "Get entries from the database, optionally limited to a date 61 range or count" 62 (labels 63 ((curr-year () 64 (nth 5 (multiple-value-list (get-decoded-time)))) 65 66 (start-range (year month) 67 (format nil "~d-~2,'0d-~2,'0d" 68 (or year (curr-year)) 69 (or month 1) 70 1)) 71 72 (end-range (year month) 73 (let* ((working-year (or year (curr-year))) 74 (working-month (or month 12)) 75 (end-year 76 (if (eql working-month 12) 77 (+ working-year 1) 78 working-year)) 79 (end-month 80 (if (eql working-month 12) 81 1 82 (+ working-month 1)))) 83 (format nil "~d-~2,'0d-~2,'0d" end-year end-month 1))) 84 85 (where-clause (year month) 86 (if (or year month) 87 (where (:and (:>= :created_at (start-range year month)) 88 (:< :created_at (end-range year month))))))) 89 90 (mapcar transform 91 (select-dao 'blog-entries 92 (where-clause year month) 93 (order-by (:desc :created_at)) 94 (if max-entries 95 (limit max-entries)))))) 96 97 (defun update-entry (id title content &key (username "nobody") (transform #'identity)) 98 "Update entry by id. Returns the updated entry or nil if the id doesn't exist." 99 (let ((entry (get-raw-entry id))) 100 (if entry 101 (funcall transform 102 (progn (setf (entry-title entry) title) 103 (setf (entry-content entry) content) 104 (setf (entry-last-updated-by entry) username) 105 (save-dao entry) 106 entry))))) 107 108 (defun delete-entry (id) 109 "Delete the specified entry from the database. No-op if the id is invalid." 110 (let ((entry (get-raw-entry id))) 111 (if entry 112 (delete-dao entry)))) 113 114 (defun add-page (name title content &key (parent 0) (username "nobody") (transform #'identity)) 115 "Add a new page to the database" 116 (funcall transform (create-dao 'blog-pages 117 :name name 118 :parent parent 119 :title title 120 :content content 121 :username username 122 :last-updated-by username))) 123 124 (defun get-raw-page (id) 125 (find-dao 'blog-pages :id id)) 126 127 (defun get-page (id &key (transform #'identity)) 128 "Get page by id, or NIL if the requested id isn't found" 129 (let ((entry (get-raw-page id))) 130 (if entry 131 (funcall transform entry)))) 132 133 (defun build-tree-table (dao-list transform) 134 (let ((entry-table (make-hash-table))) 135 (labels ((build-tree (raw-entry) 136 (let ((id (mito.dao.mixin:object-id raw-entry)) 137 (parent-id (page-parent raw-entry)) 138 (entry (funcall transform raw-entry))) 139 (setf (getf entry :children) 140 (getf (gethash id entry-table) :children)) 141 (setf (gethash id entry-table) entry) 142 (setf (getf (gethash parent-id entry-table) :children) 143 (cons entry 144 (getf (gethash parent-id entry-table) :children)))))) 145 (mapcar #'build-tree dao-list) 146 entry-table))) 147 148 (defun get-pages (&key (root-id 0) (transform #'identity)) 149 "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." 150 (let* ((entry-table (build-tree-table (select-dao 'blog-pages) transform))) 151 (values (gethash root-id entry-table) entry-table))) 152 153 (defun update-page (id name title content &key (username "nobody") (transform #'identity)) 154 "Update page by id. Returns the updated page or nil if the id doesn't exist." 155 (let ((entry (get-raw-page id))) 156 (if entry 157 (funcall transform 158 (progn (setf (page-name entry) name) 159 (setf (page-title entry) title) 160 (setf (page-content entry) content) 161 (setf (page-last-updated-by entry) username) 162 (save-dao entry) 163 entry))))) 164 165 (defun move-page-dao (entry parent) 166 (setf (page-parent entry) parent) 167 (save-dao entry) 168 entry) 169 170 (defun move-page (id parent &key (transform #'identity)) 171 "Move a page under a new parent page (or to the root if parent is 0 or NIL)" 172 (let ((entry (get-raw-page id))) 173 (if entry 174 (funcall transform (move-page-dao entry (or parent 0)))))) 175 176 (defun prune-subtree (entry-table root &optional skip-top) 177 (if (not skip-top) 178 (delete-dao (getf root :dao))) 179 (mapcar #'(lambda (child) (prune-subtree entry-table child)) 180 (getf root :children))) 181 182 (defun delete-page (id &key (children :move-to-parent)) 183 "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." 184 (let* ((entry-table (build-tree-table (select-dao 'blog-pages) 185 (lambda (entry) (list :dao entry)))) 186 (entry (gethash id entry-table)) 187 (entry-dao (getf entry :dao)) 188 (entry-parent (if entry-dao (page-parent entry-dao))) 189 (entry-children (getf entry :children))) 190 (if entry-dao 191 (progn 192 (delete-dao entry-dao) 193 (ecase children 194 (:move-to-parent (mapcar #'(lambda (child) 195 (move-page-dao (getf child :dao) entry-parent)) 196 entry-children)) 197 (:move-to-root (mapcar #'(lambda (child) 198 (move-page-dao (getf child :dao) 0)) 199 entry-children)) 200 (:delete (prune-subtree entry-table entry t)))))))