miniblog.lisp (24979B)
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 (("move" #\m) :type integer :optional t :documentation "Move a page from its current path to a new one.") 53 (("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.") 54 (("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.") 55 (("regen-all" #\r) :type boolean :optional t 56 :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.") 57 (("help" #\h) :type boolean :optional t :documentation "This help information"))) 58 59 (defun main (args) 60 (handle-command-line 61 +command-line-spec+ 62 'miniblog 63 :command-line args 64 :name "miniblog")) 65 66 (defun entry-point () 67 (main *command-line-arguments*)) 68 69 (defun get-username () 70 (uiop:getenv "USER")) 71 72 (defun make-generators () 73 (setf *generator* 74 (miniblog.content:make-generator :title *blog-title* 75 :root-uri *root-uri* 76 :header *blog-header* 77 :links *blog-links* 78 :stylesheet *blog-stylesheet*)) 79 (setf *page-generator* 80 (miniblog.content:make-page-generator :title *blog-title* 81 :root-uri *root-uri* 82 :header *blog-header* 83 :links *blog-links* 84 :stylesheet *blog-stylesheet*)) 85 (setf *rss-generator* 86 (miniblog.content:make-rss-generator :title *blog-title* 87 :link *blog-link* 88 :description *blog-description* 89 :image-url *blog-image-url* 90 :language *blog-language* 91 :copyright *blog-copyright* 92 :managing-editor *blog-managing-editor* 93 :webmaster *blog-webmaster* 94 :category *blog-category*))) 95 96 (defun get-index-file-for-path (path) 97 (merge-pathnames 98 (make-pathname :name "index" :type "html") 99 path)) 100 101 (defun get-index-file () 102 (get-index-file-for-path *public-html*)) 103 104 (defun get-page-path (path-list) 105 (merge-pathnames 106 (make-pathname :directory (append '(:relative "page") path-list)) 107 *public-html*)) 108 109 (defun get-rss-file () 110 (merge-pathnames 111 (make-pathname :name "rss" :type "xml") 112 *public-html*)) 113 114 (defun get-monthly-path (year month) 115 (merge-pathnames 116 (make-pathname :directory 117 (list :relative (write-to-string year) 118 (format nil "~2,'0d" month))) 119 *public-html*)) 120 121 (defun cleanup-path (filepath) 122 (format t "Cleaning ~S...~%" filepath) 123 (cond 124 ((and (string= (pathname-name filepath) "index") 125 (string= (pathname-type filepath) "html")) 126 (delete-file filepath)) 127 ((fad:directory-pathname-p filepath) 128 (handler-case (uiop:delete-empty-directory filepath) 129 (file-error (e) 130 (declare (ignore e)) 131 (format t "~cDirectory ~a not empty...~%" #\tab filepath)))) 132 (t (format t "~cUnrecognized file ~a, ignoring...~%" #\tab filepath)))) 133 134 (defun flush-path (path) 135 (fad:walk-directory path #'cleanup-path 136 :directories :depth-first 137 :if-does-not-exist :ignore 138 :follow-symlinks nil)) 139 140 (defun flush-page-path (path-list) 141 (flush-path (get-page-path path-list))) 142 143 (defun flush-monthly-path (year month) 144 (flush-path (get-monthly-path year month))) 145 146 (defun get-path-and-description-for-entry (entry) 147 (let* ((year (nth 0 entry)) 148 (month (nth 1 entry))) 149 (cond 150 ((eql year :index) (values (get-index-file) "index")) 151 ((eql year :page) (values (get-index-file-for-path (get-page-path month)) 152 (str:join "/" month))) 153 ((eql year :rss) (values (get-rss-file) "RSS feed")) 154 (t (values 155 (get-index-file-for-path (get-monthly-path year month)) 156 (format nil "archive for ~d/~2,'0d" year month)))))) 157 158 (defun regenerate-file (entry) 159 (multiple-value-bind (path description) 160 (get-path-and-description-for-entry entry) 161 (format t "Regenerating ~a...~%" description) 162 (ensure-directories-exist path) 163 (let ((year (nth 0 entry)) 164 (content (nth 2 entry))) 165 (if (and (eql year :rss) (null content)) 166 (format t "Can't generate valid RSS feed, skipping...~%") 167 (with-open-file (output path :direction :output :if-exists :supersede) 168 (princ content output) 169 (fresh-line output)))))) 170 171 (defun regenerate-index-and-given-month (entries year month) 172 (let ((rss-content (miniblog.content:gen-rss-feed entries 173 :generator *rss-generator*)) 174 (pages (miniblog.data:get-pages))) 175 (regenerate-file (list :rss nil rss-content)) 176 (regenerate-file (list :index nil 177 (miniblog.content:gen-index entries pages 178 :enable-rss rss-content 179 :twitter-card *twitter-card* 180 :generator *generator*))) 181 (regenerate-file (car (miniblog.content:gen-month entries year month pages 182 :enable-rss rss-content 183 :twitter-card *twitter-card* 184 :generator *generator*))))) 185 186 (defun regenerate-page-and-parent-and-children (parent-path page-id pages) 187 (let* ((entries (miniblog.data:get-entries)) 188 (subtree-root (miniblog.content:get-page-by-path parent-path pages)) 189 (archive-date-list (miniblog.content:get-archive-date-list entries)) 190 (rss-content (miniblog.content:gen-rss-feed entries 191 :generator *rss-generator*))) 192 (regenerate-file (list :page parent-path 193 (miniblog.content:gen-page subtree-root 194 parent-path 195 pages 196 :enable-rss rss-content 197 :twitter-card *twitter-card* 198 :generator *page-generator* 199 :archive-date-list archive-date-list))) 200 (loop for page in (getf subtree-root :children) 201 do (let ((path (append parent-path (list (getf page :name))))) 202 (regenerate-file (list :page 203 path 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 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)) 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 :username (get-username))) 250 (year-month (miniblog.content:year-month-of-entry new-entry)) 251 (year (car year-month)) 252 (month (cdr year-month))) 253 (if (or regen (new-month-p year month)) 254 (regenerate-all) 255 (regenerate-index-and-given-month (miniblog.data:get-entries) year month))) 256 (format t "Abandoning post...~%"))) 257 258 (defmethod add-entry ((entry-type (eql :page)) uri regen) 259 (or (when-let* ((uri-components (str:split "/" uri)) 260 (name (car (last uri-components)))) 261 (let* ((parent-path (butlast uri-components)) 262 (parent-id (if parent-path 263 (miniblog.content:get-page-id-by-path parent-path 264 (miniblog.data:get-pages)) 265 0))) 266 (if-let ((text (miniblog.edit:edit-text))) 267 (let* ((post (miniblog.edit:get-title-and-content text)) 268 (title (nth 0 post)) 269 (content (nth 1 post)) 270 (new-entry (miniblog.data:add-page 271 name 272 (or title "Untitled") 273 content 274 :parent parent-id 275 :username (get-username)))) 276 (if (or regen (= (length uri-components) 1)) 277 (regenerate-all) 278 (regenerate-page-and-parent-and-children parent-path 279 (getf new-entry :id) 280 (miniblog.data:get-pages)))) 281 (format t "Abandoning page...~%"))) 282 t) 283 (format t "Invalid page name ~a~%" uri))) 284 285 (defun date-format (datetime) 286 (miniblog.format:long-date-format datetime)) 287 288 (defgeneric get-entry (entry-type id) 289 (:documentation "Get an entry of type ENTRY-TYPE with id ID")) 290 291 (defmethod get-entry ((entry-type (eql :post)) id) 292 (miniblog.data:with-entry-id entry id 293 (format t "ID: ~d~%" (getf entry :id)) 294 (format t "Created: ~A by ~A~%" 295 (date-format (getf entry :created-at)) (getf entry :created-by)) 296 (format t "Last updated: ~A by ~A~%" 297 (date-format (getf entry :last-updated-at)) (getf entry :last-updated-by)) 298 (format t "Title: ~A~%" (getf entry :title)) 299 (format t "Content:~%~A~%" (getf entry :content)))) 300 301 (defmethod get-entry ((entry-type (eql :page)) id) 302 (miniblog.data:with-page-id page id 303 (format t "ID: ~d~%" (getf page :id)) 304 (format t "Path: page/~a~%" (str:join "/" (miniblog.content:get-path-to-page 305 id 306 (cadr (multiple-value-list (miniblog.data:get-pages)))))) 307 (format t "Created: ~A by ~A~%" 308 (date-format (getf page :created-at)) (getf page :created-by)) 309 (format t "Last updated: ~A by ~A~%" 310 (date-format (getf page :last-updated-at)) (getf page :last-updated-by)) 311 (format t "Title: ~A~%" (getf page :title)) 312 (format t "Content:~%~A~%" (getf page :content)))) 313 314 (defun make-template (title content) 315 (with-output-to-string (out) 316 (princ (or title "Untitled post") out) 317 (terpri out) 318 (terpri out) 319 (princ content out))) 320 321 (defgeneric edit-entry (entry-type id regen) 322 (:documentation "Edit an entry of type ENTRY-TYPE with id ID")) 323 324 (defmethod edit-entry ((entry-type (eql :post)) id regen) 325 (miniblog.data:with-entry-id entry id 326 (if-let ((text (miniblog.edit:edit-text 327 :template (make-template (getf entry :title) (getf entry :content))))) 328 (let* ((post (miniblog.edit:get-title-and-content text)) 329 (title (nth 0 post)) 330 (content (nth 1 post))) 331 (miniblog.data:update-entry 332 id title content 333 :username (get-username)) 334 (let* ((created-at (getf entry :created-at)) 335 (year (timestamp-year created-at)) 336 (month (timestamp-month created-at))) 337 (if (not regen) 338 (regenerate-index-and-given-month (miniblog.data:get-entries) year month) 339 (regenerate-all)))) 340 (format t "No change, abandoning...~%")))) 341 342 (defmethod edit-entry ((entry-type (eql :page)) id regen) 343 (miniblog.data:with-page-id entry id 344 (if-let ((text (miniblog.edit:edit-text 345 :template (make-template (getf entry :title) (getf entry :content))))) 346 (let* ((page (miniblog.edit:get-title-and-content text)) 347 (title (nth 0 page)) 348 (content (nth 1 page)) 349 (new-entry (miniblog.data:update-page 350 id (getf entry :name) title content 351 :username (get-username)))) 352 (if (not regen) 353 (let* ((pages-tuple (multiple-value-list (miniblog.data:get-pages))) 354 (page-table (cadr pages-tuple)) 355 (parent-id (getf new-entry :parent)) 356 (root (gethash 0 page-table)) 357 (path (miniblog.content:get-path-to-page parent-id page-table))) 358 (regenerate-page-and-parent-and-children path id root)) 359 (regenerate-all))) 360 (format t "No change, abandoning...~%")))) 361 362 363 (defun removed-month-p (year month) 364 "Determine if there are 0 entries in the given month and year" 365 (eql (entries-in-month year month) 0)) 366 367 (defgeneric delete-entry (entry-type id children-to-root regen) 368 (: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.")) 369 370 (defmethod delete-entry ((entry-type (eql :post)) id children-to-root regen) 371 (declare (ignore children-to-root)) 372 (miniblog.data:with-entry-id entry id 373 (format t "Deleting post ID ~d...~%" id) 374 (miniblog.data:delete-entry id) 375 (let* ((created-at (getf entry :created-at)) 376 (year (timestamp-year created-at)) 377 (month (timestamp-month created-at))) 378 (flush-monthly-path year month) 379 (if (or regen (removed-month-p year month)) 380 (regenerate-all) 381 (regenerate-index-and-given-month (miniblog.data:get-entries) year month))))) 382 383 (defmethod delete-entry ((entry-type (eql :page)) id children-to-root regen) 384 (miniblog.data:with-page-id page id 385 (format t "Delete page ID ~d...~%" id) 386 (let* ((pages-tuple (multiple-value-list (miniblog.data:get-pages))) 387 (page-table (cadr pages-tuple)) 388 (path (miniblog.content:get-path-to-page id page-table))) 389 (miniblog.data:delete-page id :children (if children-to-root 390 :children-to-root 391 :children-to-parent)) 392 (flush-page-path path) 393 (if (or children-to-root (< (length path) 3)) 394 (regenerate-all) 395 (let* ((parent-id (getf page :parent)) 396 (pages-tuple (multiple-value-list (miniblog.data:get-pages))) 397 (page-table (cadr pages-tuple)) 398 (parent (gethash parent-id page-table)) 399 (parent-of-parent-id (getf parent :parent)) 400 (root (gethash 0 page-table)) 401 (path (miniblog.content:get-path-to-page parent-of-parent-id page-table))) 402 (regenerate-page-and-parent-and-children path parent-id root)))))) 403 404 (defgeneric move-entry (entry-type id uri regen) 405 (:documentation "Move entry ID of type ENTRY-TYPE to location specified in URI. Only applies to hierarchical entry types.")) 406 407 (defmethod move-entry ((entry-type (eql :post)) id uri regen) 408 (declare (ignore id uri regen)) 409 (format t "Posts can't be moved!~%")) 410 411 (defmethod move-entry ((entry-type (eql :page)) id uri regen) 412 (declare (ignore regen)) 413 (or (when-let* ((uri-components (str:split "/" uri)) 414 (name (car (last uri-components))) 415 (parent-path (butlast uri-components)) 416 (parent-id (miniblog.content:get-page-id-by-path 417 parent-path 418 (miniblog.data:get-pages)))) 419 420 (miniblog.data:move-page id parent-id) 421 ;; FIXME: Regeneration logic for moving pages is complex so 422 ;; we're punting for now but we should avoid doing a full 423 ;; regen unless we have to. The basic logic should look 424 ;; something like: 425 ;; IF regen is true OR old path is top-level OR new path top-level 426 ;; THEN 427 ;; regenerate-all 428 ;; ELSE 429 ;; regenerate old parent tree 430 ;; regenerate new parent tree 431 (regenerate-all) 432 t) 433 (format t "Invalid path ~a~%" uri))) 434 435 (defgeneric list-entries (entry-type start n) 436 (: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.")) 437 438 (defmethod list-entries ((entry-type (eql :post)) start n) 439 (let* ((entries (miniblog.data:get-entries)) 440 (first (or start 0)) 441 (last (if n 442 (+ first n) 443 (length entries)))) 444 (dolist (entry (subseq entries first last)) 445 (format t "~d \"~a\" ~a~%" (getf entry :id) (getf entry :title) (getf entry :created-by))))) 446 447 (defmethod list-entries ((entry-type (eql :page)) start n) 448 (declare (ignore n)) 449 (labels ((traverse (node depth) 450 (destructuring-bind (&key id name title children created-by &allow-other-keys) 451 node 452 (if (not (or (null id) (= id 0))) 453 (format t "~v{~a~:*~}~a (ID ~d) - \"~a\" ~a~%" depth '(" ") name id title created-by)) 454 (loop for entry in children 455 do (traverse entry (1+ depth)))))) 456 (let ((pages (miniblog.data:get-pages start))) 457 (traverse pages 0)))) 458 459 (defun init-tz () 460 (reread-timezone-repository)) 461 462 (defun get-db-filename () 463 (namestring (merge-pathnames 464 (user-homedir-pathname) 465 (make-pathname :name ".miniblog" :type "db")))) 466 467 (defun set-config-and-defaults () 468 (setf *root-uri* (format nil "/~~~a/" (get-username))) 469 (setf *public-html* 470 (merge-pathnames 471 (make-pathname :directory '(:relative "public_html")) 472 (user-homedir-pathname))) 473 (setf *db-config* (list :sqlite3 :database-name (get-db-filename))) 474 (with-open-file (config 475 (merge-pathnames 476 (make-pathname :name ".miniblogrc") 477 (user-homedir-pathname)) 478 :direction :input :if-does-not-exist nil) 479 (if config 480 (load config))) 481 (if (stringp *public-html*) 482 (setf *public-html* (uiop:parse-native-namestring (uiop:native-namestring *public-html*))))) 483 484 (defun initialize () 485 (init-tz) 486 (set-config-and-defaults) 487 (make-generators)) 488 489 (defun miniblog (&key add get edit delete list (start 0) n page move uri children-to-root regen-all help) 490 (declare (ignore help)) 491 (initialize) 492 (apply #'miniblog.db:init *db-config*) 493 (let ((*default-timezone* *blog-timezone*) 494 (entry-type (if page :page :post))) 495 (cond (add (add-entry entry-type uri regen-all)) 496 (get (get-entry entry-type get)) 497 (edit (edit-entry entry-type edit regen-all)) 498 (delete (delete-entry entry-type delete children-to-root regen-all)) 499 (list (list-entries entry-type start n)) 500 (move (move-entry entry-type move uri regen-all)) 501 (regen-all (regenerate-all)) 502 (t (show-option-help +command-line-spec+)))))