miniblog.lisp (26197B)
1 (in-package :miniblog) 2 3 ;;; The following are basic configuration elements. Most have sensible defaults. 4 (defvar *blog-title* "Miniblog") 5 (defvar *blog-header* nil) ; Raw filename of an HTML chunk to throw at the top 6 ; of the body, eg "<h2>My Blog</h2>" 7 (defvar *blog-links* nil) ; A list of cons cells of the format (text . url) 8 ; Populates the left-hand menu. 9 (defvar *blog-stylesheet* nil) ; Optional external CSS stylesheet. 10 (defvar *blog-timezone* *default-timezone*) ; Timezone in local-time form, eg 11 ; (local-time:find-timezone-by-location-name "US/Pacific") 12 (defvar *public-html*) ; HTML root in pathname form, defaults to "~/public_html" 13 ; If it's set to a string in .miniblogrc, will be 14 ; translated with uiop:parse-native-namestring 15 (defvar *root-uri*) ; Absolute or relative root uri, defaults to "~username" 16 (defvar *db-config*) ; Database configuration, defaults to sqlite3 ~/.miniblog.db 17 (defvar *generator*) ; Function to generate post pages, see content.lisp 18 (defvar *page-generator*) ; Function to generate hierarchical pages, see content.lisp 19 (defvar *rss-generator*) ; Function to generate RSS feed, see content.lisp 20 21 ;;; The following are all used to populate RSS channel elements. 22 ;;; *BLOG-DESCRIPTION* and *BLOG-LINK* are the minimum required for an 23 ;;; RSS feed to be generated. See https://validator.w3.org/feed/docs/rss2.html 24 (defvar *blog-description* "Powered by Common Lisp") 25 (defvar *blog-link* nil) 26 (defvar *blog-image-url* nil) 27 (defvar *blog-language* nil) 28 (defvar *blog-category* nil) 29 (defvar *blog-copyright* nil) 30 (defvar *blog-managing-editor* nil) 31 (defvar *blog-webmaster* nil) 32 33 ;;; The following are configurations for social media cards et al; currently 34 ;;; simple Twitter summary cards are supported. *TWITTER-CARD* can be a simple 35 ;;; truthy value in which case a basic card is generated or it can be a plist 36 ;;; with keys defining the card metadata. Currently supported keys: 37 ;;; 38 ;;; :IMAGE - URL to the image to populate the twitter:image tag 39 (defvar *twitter-card* nil) 40 41 (defparameter +command-line-spec+ 42 '((("add" #\a) :type boolean :optional t :documentation "Add new post") 43 (("edit" #\e) :type integer :optional t :documentation "Edit a post by ID") 44 (("get" #\g) :type integer :optional t :documentation "Get a post by ID") 45 (("delete" #\d) :type integer :optional t :documentation "Delete a post by ID") 46 (("list" #\l) :type boolean :optional t :documentation "List posts") 47 (("start" #\s) :type integer :optional t 48 :documentation "When listing posts, first post to list (default 0)") 49 ((#\n) :type integer :optional t 50 :documentation "When listing posts, max number of posts to list (default all)") 51 (("page" #\p) :type boolean :optional t :documentation "This parameter specifies operations to be done on pages, rather than posts. EG saying -a -p means you intend to add a new page rather than a new post. Page IDs are in a separate namespace from post IDs.") 52 (("draft" #\f) :type boolean :optional t :documentation "When specified for adding or editing a post, this will set the post as a draft. If the post is already published and this is specified, the post will be unpublished back to the drafts.") 53 (("move" #\m) :type integer :optional t :documentation "Move a page from its current path to a new one.") 54 (("uri" #\u) :type string :optional t :documentation "When adding a new page, this specifies the path to the new page in relative URI format. For instance, \"-a -p -u foo/bar\" would specify that the new page should be created with the name bar as a child of page foo. This is only valid if root page foo actually exists. This is also used in conjunction with -m to specify the target path for the page being moved, with the same restriction. A leading / will be ignored so \"-u /foo/bar/baz\" and \"-u foo/bar/baz\" mean the same thing.") 55 (("children-to-root" #\c) :type boolean :optional t :documentation "When deleting a page, normally child pages of the page being deleted will be moved to the parent page of the deleted page. If -c is specified, the pages will instead be moved to the root.") 56 (("regen-all" #\r) :type boolean :optional t 57 :documentation "When adding or editing, regenerate all pages instead of just those miniblog thinks have changed. Can also be invoked standalone to regenerate the HTML directly.") 58 (("help" #\h) :type boolean :optional t :documentation "This help information"))) 59 60 (defun main (args) 61 (handle-command-line 62 +command-line-spec+ 63 'miniblog 64 :command-line args 65 :name "miniblog")) 66 67 (defun entry-point () 68 (main *command-line-arguments*)) 69 70 (defun get-username () 71 (uiop:getenv "USER")) 72 73 (defun make-generators () 74 (setf *generator* 75 (miniblog.content:make-generator :title *blog-title* 76 :root-uri *root-uri* 77 :header *blog-header* 78 :links *blog-links* 79 :stylesheet *blog-stylesheet*)) 80 (setf *page-generator* 81 (miniblog.content:make-page-generator :title *blog-title* 82 :root-uri *root-uri* 83 :header *blog-header* 84 :links *blog-links* 85 :stylesheet *blog-stylesheet*)) 86 (setf *rss-generator* 87 (miniblog.content:make-rss-generator :title *blog-title* 88 :link *blog-link* 89 :description *blog-description* 90 :image-url *blog-image-url* 91 :language *blog-language* 92 :copyright *blog-copyright* 93 :managing-editor *blog-managing-editor* 94 :webmaster *blog-webmaster* 95 :category *blog-category*))) 96 97 (defun get-index-file-for-path (path) 98 (merge-pathnames 99 (make-pathname :name "index" :type "html") 100 path)) 101 102 (defun get-index-file () 103 (get-index-file-for-path *public-html*)) 104 105 (defun get-page-path (path-list) 106 (merge-pathnames 107 (make-pathname :directory (append '(:relative "page") path-list)) 108 *public-html*)) 109 110 (defun get-rss-file () 111 (merge-pathnames 112 (make-pathname :name "rss" :type "xml") 113 *public-html*)) 114 115 (defun get-monthly-path (year month) 116 (merge-pathnames 117 (make-pathname :directory 118 (list :relative (write-to-string year) 119 (format nil "~2,'0d" month))) 120 *public-html*)) 121 122 (defun cleanup-path (filepath) 123 (format t "Cleaning ~S...~%" filepath) 124 (cond 125 ((and (string= (pathname-name filepath) "index") 126 (string= (pathname-type filepath) "html")) 127 (delete-file filepath)) 128 ((fad:directory-pathname-p filepath) 129 (handler-case (uiop:delete-empty-directory filepath) 130 (file-error (e) 131 (declare (ignore e)) 132 (format t "~cDirectory ~a not empty...~%" #\tab filepath)))) 133 (t (format t "~cUnrecognized file ~a, ignoring...~%" #\tab filepath)))) 134 135 (defun flush-path (path) 136 (fad:walk-directory path #'cleanup-path 137 :directories :depth-first 138 :if-does-not-exist :ignore 139 :follow-symlinks nil)) 140 141 (defun flush-page-path (path-list) 142 (flush-path (get-page-path path-list))) 143 144 (defun flush-monthly-path (year month) 145 (flush-path (get-monthly-path year month))) 146 147 (defun get-path-and-description-for-entry (entry) 148 (let* ((year (nth 0 entry)) 149 (month (nth 1 entry))) 150 (cond 151 ((eql year :index) (values (get-index-file) "index")) 152 ((eql year :page) (values (get-index-file-for-path (get-page-path month)) 153 (str:join "/" month))) 154 ((eql year :rss) (values (get-rss-file) "RSS feed")) 155 (t (values 156 (get-index-file-for-path (get-monthly-path year month)) 157 (format nil "archive for ~d/~2,'0d" year month)))))) 158 159 (defun regenerate-file (entry) 160 (multiple-value-bind (path description) 161 (get-path-and-description-for-entry entry) 162 (format t "Regenerating ~a...~%" description) 163 (ensure-directories-exist path) 164 (let ((year (nth 0 entry)) 165 (content (nth 3 entry))) 166 (if (and (eql year :rss) (null content)) 167 (format t "Can't generate valid RSS feed, skipping...~%") 168 (with-open-file (output path :direction :output :if-exists :supersede) 169 (princ content output) 170 (fresh-line output)))))) 171 172 (defun regenerate-index-and-given-month (entries year month) 173 (let ((rss-content (miniblog.content:gen-rss-feed entries 174 :generator *rss-generator*)) 175 (pages (miniblog.data:get-pages))) 176 (regenerate-file (list :rss nil nil rss-content)) 177 (regenerate-file (list :index nil nil 178 (miniblog.content:gen-index entries pages 179 :enable-rss rss-content 180 :twitter-card *twitter-card* 181 :generator *generator*))) 182 (regenerate-file (car (miniblog.content:gen-month entries year month pages 183 :enable-rss rss-content 184 :twitter-card *twitter-card* 185 :generator *generator*))))) 186 187 (defun regenerate-page-and-parent-and-children (parent-path page-id pages) 188 (let* ((entries (miniblog.data:get-entries)) 189 (subtree-root (miniblog.content:get-page-by-path parent-path pages)) 190 (archive-date-list (miniblog.content:get-archive-date-list entries)) 191 (rss-content (miniblog.content:gen-rss-feed entries 192 :generator *rss-generator*))) 193 (regenerate-file (list :page parent-path nil 194 (miniblog.content:gen-page subtree-root 195 parent-path 196 pages 197 :enable-rss rss-content 198 :twitter-card *twitter-card* 199 :generator *page-generator* 200 :archive-date-list archive-date-list))) 201 (loop for page in (getf subtree-root :children) 202 do (let ((path (append parent-path (list (getf page :name))))) 203 (regenerate-file (list :page path nil 204 (miniblog.content:gen-page 205 page path pages 206 :enable-rss rss-content 207 :twitter-card *twitter-card* 208 :generator *page-generator* 209 :archive-date-list archive-date-list))))) 210 (let ((this-page (find-if #'(lambda (entry) (= page-id (getf entry :id))) (getf subtree-root :children)))) 211 (mapcar #'regenerate-file (miniblog.content:gen-all-pages this-page 212 :prefix parent-path 213 :all-pages pages 214 :enable-rss rss-content 215 :twitter-card *twitter-card* 216 :generator *page-generator* 217 :archive-date-list archive-date-list))))) 218 219 (defun regenerate-all () 220 (let ((all (miniblog.content:gen-all (miniblog.data:get-entries) 221 (miniblog.data:get-pages) 222 :generator *generator* 223 :page-generator *page-generator* 224 :rss-generator *rss-generator* 225 :twitter-card *twitter-card*))) 226 (mapcar #'regenerate-file all))) 227 228 (defun entries-in-month (year month) 229 "Determine number of entries in a given month and year" 230 (let ((entries-in-month (miniblog.data:get-entries :year year :month month))) 231 (length entries-in-month))) 232 233 (defun new-month-p (year month) 234 "Determine if there is only one entry in a given month and year" 235 (eql (entries-in-month year month) 1)) 236 237 (defgeneric add-entry (entry-type draft uri regen) 238 (:documentation "Add a new entry of type ENTRY-TYPE. URI specifies the logical location of the new entry which is only valid for certain entry types.")) 239 240 (defmethod add-entry ((entry-type (eql :post)) draft uri regen) 241 (declare (ignore uri)) 242 (if-let ((text (miniblog.edit:edit-text))) 243 (let* ((post (miniblog.edit:get-title-and-content text)) 244 (title (nth 0 post)) 245 (content (nth 1 post)) 246 (new-entry (miniblog.data:add-entry 247 (or title "Untitled") 248 content 249 :draftp draft 250 :rendered-content (miniblog.format:markdown content) 251 :username (get-username))) 252 (year-month (miniblog.content:year-month-of-entry new-entry)) 253 (year (car year-month)) 254 (month (cdr year-month))) 255 (if (or regen (new-month-p year month)) 256 (regenerate-all) 257 (regenerate-index-and-given-month (miniblog.data:get-entries) year month))) 258 (format t "Abandoning post...~%"))) 259 260 (defmethod add-entry ((entry-type (eql :page)) draft uri regen) 261 (or (when-let* ((uri-components (str:split "/" uri)) 262 (name (car (last uri-components)))) 263 (let* ((parent-path (butlast uri-components)) 264 (parent-id (if parent-path 265 (miniblog.content:get-page-id-by-path parent-path 266 (miniblog.data:get-pages)) 267 0))) 268 (if-let ((text (miniblog.edit:edit-text))) 269 (let* ((post (miniblog.edit:get-title-and-content text)) 270 (title (nth 0 post)) 271 (content (nth 1 post)) 272 (new-entry (miniblog.data:add-page 273 name 274 (or title "Untitled") 275 content 276 :draftp draft 277 :rendered-content (miniblog.format:markdown content) 278 :parent parent-id 279 :username (get-username)))) 280 (if (or regen (= (length uri-components) 1)) 281 (regenerate-all) 282 (regenerate-page-and-parent-and-children parent-path 283 (getf new-entry :id) 284 (miniblog.data:get-pages)))) 285 (format t "Abandoning page...~%"))) 286 t) 287 (format t "Invalid page name ~a~%" uri))) 288 289 (defun date-format (datetime) 290 (miniblog.format:long-date-format datetime)) 291 292 (defgeneric get-entry (entry-type id) 293 (:documentation "Get an entry of type ENTRY-TYPE with id ID")) 294 295 (defmethod get-entry ((entry-type (eql :post)) id) 296 (miniblog.data:with-entry-id entry id 297 (format t "ID: ~d~@[~* (DRAFT)~]~%" (getf entry :id) (getf entry :draftp)) 298 (format t "Created: ~A by ~A~%" 299 (date-format (getf entry :created-at)) (getf entry :created-by)) 300 (format t "Last updated: ~A by ~A~%" 301 (date-format (getf entry :last-updated-at)) (getf entry :last-updated-by)) 302 (format t "Title: ~A~%" (getf entry :title)) 303 (format t "Content:~%~A~%" (getf entry :content)))) 304 305 (defmethod get-entry ((entry-type (eql :page)) id) 306 (miniblog.data:with-page-id page id 307 (format t "ID: ~d~@[~* (DRAFT)~]~%" (getf page :id) (getf page :draftp)) 308 (format t "Path: page/~a~%" (str:join "/" (miniblog.content:get-path-to-page 309 id 310 (cadr (multiple-value-list (miniblog.data:get-pages)))))) 311 (format t "Created: ~A by ~A~%" 312 (date-format (getf page :created-at)) (getf page :created-by)) 313 (format t "Last updated: ~A by ~A~%" 314 (date-format (getf page :last-updated-at)) (getf page :last-updated-by)) 315 (format t "Title: ~A~%" (getf page :title)) 316 (format t "Content:~%~A~%" (getf page :content)))) 317 318 (defun make-template (title content) 319 (with-output-to-string (out) 320 (princ (or title "Untitled post") out) 321 (terpri out) 322 (terpri out) 323 (princ content out))) 324 325 (defgeneric edit-entry (entry-type id draftp regen) 326 (:documentation "Edit an entry of type ENTRY-TYPE with id ID")) 327 328 (defmethod edit-entry ((entry-type (eql :post)) id draftp regen) 329 (miniblog.data:with-entry-id entry id 330 (if-let ((text (miniblog.edit:edit-text 331 :template (make-template (getf entry :title) (getf entry :content))))) 332 (let* ((was-draft-p (getf entry :draftp)) 333 (post (miniblog.edit:get-title-and-content text)) 334 (title (nth 0 post)) 335 (content (nth 1 post))) 336 (miniblog.data:update-entry 337 id title content 338 :rendered-content (miniblog.format:markdown content) 339 :username (get-username) 340 :draftp draftp 341 :reset-timestamp-p (and was-draft-p (not draftp))) 342 (let* ((created-at (getf entry :created-at)) 343 (year (timestamp-year created-at)) 344 (month (timestamp-month created-at))) 345 (if (and (not regen) (eql draftp was-draft-p)) 346 (regenerate-index-and-given-month (miniblog.data:get-entries) year month) 347 (regenerate-all)))) 348 (format t "No change, abandoning...~%")))) 349 350 (defmethod edit-entry ((entry-type (eql :page)) id draftp regen) 351 (miniblog.data:with-page-id entry id 352 (if-let ((text (miniblog.edit:edit-text 353 :template (make-template (getf entry :title) (getf entry :content))))) 354 (let* ((was-draft-p (getf entry :draftp)) 355 (page (miniblog.edit:get-title-and-content text)) 356 (title (nth 0 page)) 357 (content (nth 1 page)) 358 (new-entry (miniblog.data:update-page 359 id (getf entry :name) title content 360 :rendered-content (miniblog.format:markdown content) 361 :username (get-username) 362 :draftp draftp 363 :reset-timestamp-p (and was-draft-p (not draftp))))) 364 (if (and (not regen) (eql draftp was-draft-p)) 365 (let* ((pages-tuple (multiple-value-list (miniblog.data:get-pages))) 366 (page-table (cadr pages-tuple)) 367 (parent-id (getf new-entry :parent)) 368 (root (gethash 0 page-table)) 369 (path (miniblog.content:get-path-to-page parent-id page-table))) 370 (regenerate-page-and-parent-and-children path id root)) 371 (regenerate-all))) 372 (format t "No change, abandoning...~%")))) 373 374 375 (defun removed-month-p (year month) 376 "Determine if there are 0 entries in the given month and year" 377 (eql (entries-in-month year month) 0)) 378 379 (defgeneric delete-entry (entry-type id children-to-root regen) 380 (:documentation "Delete entry of type ENTRY-TYPE with id ID. CHILDREN-TO-ROOT specifies how child entries will be rerooted; only applies to hierarchical entry types.")) 381 382 (defmethod delete-entry ((entry-type (eql :post)) id children-to-root regen) 383 (declare (ignore children-to-root)) 384 (miniblog.data:with-entry-id entry id 385 (format t "Deleting post ID ~d...~%" id) 386 (miniblog.data:delete-entry id) 387 (let* ((created-at (getf entry :created-at)) 388 (year (timestamp-year created-at)) 389 (month (timestamp-month created-at))) 390 (flush-monthly-path year month) 391 (if (or regen (removed-month-p year month)) 392 (regenerate-all) 393 (regenerate-index-and-given-month (miniblog.data:get-entries) year month))))) 394 395 (defmethod delete-entry ((entry-type (eql :page)) id children-to-root regen) 396 (miniblog.data:with-page-id page id 397 (format t "Delete page ID ~d...~%" id) 398 (let* ((pages-tuple (multiple-value-list (miniblog.data:get-pages))) 399 (page-table (cadr pages-tuple)) 400 (path (miniblog.content:get-path-to-page id page-table))) 401 (miniblog.data:delete-page id :children (if children-to-root 402 :children-to-root 403 :children-to-parent)) 404 (flush-page-path path) 405 (if (or children-to-root (< (length path) 3)) 406 (regenerate-all) 407 (let* ((parent-id (getf page :parent)) 408 (pages-tuple (multiple-value-list (miniblog.data:get-pages))) 409 (page-table (cadr pages-tuple)) 410 (parent (gethash parent-id page-table)) 411 (parent-of-parent-id (getf parent :parent)) 412 (root (gethash 0 page-table)) 413 (path (miniblog.content:get-path-to-page parent-of-parent-id page-table))) 414 (regenerate-page-and-parent-and-children path parent-id root)))))) 415 416 (defgeneric move-entry (entry-type id uri regen) 417 (:documentation "Move entry ID of type ENTRY-TYPE to location specified in URI. Only applies to hierarchical entry types.")) 418 419 (defmethod move-entry ((entry-type (eql :post)) id uri regen) 420 (declare (ignore id uri regen)) 421 (format t "Posts can't be moved!~%")) 422 423 (defmethod move-entry ((entry-type (eql :page)) id uri regen) 424 (declare (ignore regen)) 425 (or (when-let* ((uri-components (str:split "/" uri)) 426 (name (car (last uri-components))) 427 (parent-path (butlast uri-components)) 428 (parent-id (miniblog.content:get-page-id-by-path 429 parent-path 430 (miniblog.data:get-pages)))) 431 432 (miniblog.data:move-page id parent-id) 433 ;; FIXME: Regeneration logic for moving pages is complex so 434 ;; we're punting for now but we should avoid doing a full 435 ;; regen unless we have to. The basic logic should look 436 ;; something like: 437 ;; IF regen is true OR old path is top-level OR new path top-level 438 ;; THEN 439 ;; regenerate-all 440 ;; ELSE 441 ;; regenerate old parent tree 442 ;; regenerate new parent tree 443 (regenerate-all) 444 t) 445 (format t "Invalid path ~a~%" uri))) 446 447 (defgeneric list-entries (entry-type start n) 448 (:documentation "List entries of type ENTRY-TYPE, possibly restricted to entries START through N. For hierarchical entry types, only START is consumed, specifying which entry to start listing from in the tree.")) 449 450 (defmethod list-entries ((entry-type (eql :post)) start n) 451 (let* ((entries (miniblog.data:get-entries :include-drafts-p t)) 452 (first (or start 0)) 453 (last (if n 454 (+ first n) 455 (length entries)))) 456 (dolist (entry (subseq entries first last)) 457 (format t "~d ~@[~*(DRAFT) ~]- \"~a\" ~a~%" (getf entry :id) (getf entry :draftp) (getf entry :title) (getf entry :created-by))))) 458 459 (defmethod list-entries ((entry-type (eql :page)) start n) 460 (declare (ignore n)) 461 (labels ((traverse (node depth) 462 (destructuring-bind (&key id name title children created-by draftp &allow-other-keys) 463 node 464 (if (not (or (null id) (= id 0))) 465 (format t "~v{~a~:*~}~a (ID ~d) ~@[~*(DRAFT) ~]- \"~a\" ~a~%" depth '(" ") name id draftp title created-by)) 466 (loop for entry in children 467 do (traverse entry (1+ depth)))))) 468 (let ((pages (miniblog.data:get-pages :root-id start :include-drafts-p t))) 469 (traverse pages 0)))) 470 471 (defun init-tz () 472 (reread-timezone-repository)) 473 474 (defun get-db-filename () 475 (namestring (merge-pathnames 476 (user-homedir-pathname) 477 (make-pathname :name ".miniblog" :type "db")))) 478 479 (defun set-config-and-defaults () 480 (setf *root-uri* (format nil "/~~~a/" (get-username))) 481 (setf *public-html* 482 (merge-pathnames 483 (make-pathname :directory '(:relative "public_html")) 484 (user-homedir-pathname))) 485 (setf *db-config* (list :sqlite3 :database-name (get-db-filename))) 486 (with-open-file (config 487 (merge-pathnames 488 (make-pathname :name ".miniblogrc") 489 (user-homedir-pathname)) 490 :direction :input :if-does-not-exist nil) 491 (if config 492 (load config))) 493 (if (stringp *public-html*) 494 (setf *public-html* (uiop:parse-native-namestring (uiop:native-namestring *public-html*))))) 495 496 (defun initialize () 497 (init-tz) 498 (set-config-and-defaults) 499 (make-generators)) 500 501 (defun miniblog (&key add get edit delete list (start 0) n page draft move uri children-to-root regen-all help) 502 (declare (ignore help)) 503 (initialize) 504 (apply #'miniblog.db:init *db-config*) 505 (let ((*default-timezone* *blog-timezone*) 506 (entry-type (if page :page :post))) 507 (cond (add (add-entry entry-type draft uri regen-all)) 508 (get (get-entry entry-type get)) 509 (edit (edit-entry entry-type edit draft regen-all)) 510 (delete (delete-entry entry-type delete children-to-root regen-all)) 511 (list (list-entries entry-type start n)) 512 (move (move-entry entry-type move uri regen-all)) 513 (regen-all (regenerate-all)) 514 (t (show-option-help +command-line-spec+)))))