miniblog

Miniblog: A command-line static blog system in Common Lisp
Log | Files | Refs | README | LICENSE

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)))))))