content.lisp (14145B)
1 (in-package :miniblog.content) 2 3 (let* ((this-file #.(or *compile-file-truename* *load-truename*)) 4 (src-dir (pathname-directory this-file)) 5 (templates-dir (append (butlast src-dir) '("templates")))) 6 (add-template-directory (make-pathname :directory templates-dir)) 7 (defvar *posts-template* (compile-template* "posts.dtl")) 8 (defvar *page-template* (compile-template* "page.dtl")) 9 (defvar *rss-template* (compile-template* "rss.dtl"))) 10 11 (defun augment-with-rendered-content (entry-obj) 12 (if (not (getf entry-obj :rendered-content)) 13 (let ((content (getf entry-obj :content)) 14 (augmented-entry (copy-list entry-obj))) 15 (setf (getf augmented-entry :rendered-content) (miniblog.format:markdown content)) 16 augmented-entry) 17 entry-obj)) 18 19 (defun augment-posts-with-rendered-content (posts) 20 (loop for post in posts 21 collect (augment-with-rendered-content post))) 22 23 (defun render-posts (posts pages &key stream title root-uri header links 24 stylesheet year month archive-date-list 25 enable-rss twitter-card collapse-posts-p) 26 (let ((posts (augment-posts-with-rendered-content posts))) 27 (render-template* *posts-template* stream 28 :posts posts 29 :pages pages 30 :title title 31 :root-uri root-uri 32 :header header 33 :links links 34 :stylesheet stylesheet 35 :year year 36 :month month 37 :archive-date-list archive-date-list 38 :enable-rss enable-rss 39 :twitter-card twitter-card 40 :collapse-posts-p collapse-posts-p))) 41 42 (defun render-page (page path pages &key stream title root-uri header links 43 stylesheet year month 44 archive-date-list enable-rss 45 twitter-card) 46 (let ((page (augment-with-rendered-content page))) 47 (render-template* *page-template* stream 48 :page page 49 :path path 50 :pages pages 51 :title title 52 :root-uri root-uri 53 :header header 54 :links links 55 :stylesheet stylesheet 56 :year year 57 :month month 58 :archive-date-list archive-date-list 59 :enable-rss enable-rss 60 :twitter-card twitter-card))) 61 62 (defun render-rss (posts &key stream title link description image-url language 63 copyright managing-editor webmaster category) 64 (render-template* *rss-template* stream 65 :posts posts 66 :title title 67 :link link 68 :description description 69 :image-url image-url 70 :language language 71 :copyright copyright 72 :managing-editor managing-editor 73 :webmaster webmaster 74 :category category 75 :build-date (miniblog.format:rfc-822-format (now)) 76 :collapse-posts-p t)) 77 78 (defun make-generator (&key title root-uri header links stylesheet) 79 (lambda (posts pages &key year month archive-date-list enable-rss twitter-card collapse-posts-p) 80 (render-posts posts pages 81 :title title 82 :root-uri root-uri 83 :header header 84 :links links 85 :stylesheet stylesheet 86 :year year 87 :month month 88 :archive-date-list archive-date-list 89 :enable-rss enable-rss 90 :twitter-card twitter-card 91 :collapse-posts-p collapse-posts-p))) 92 93 (defun make-page-generator (&key title root-uri header links stylesheet) 94 (lambda (page path pages &key archive-date-list enable-rss twitter-card) 95 (render-page page path pages 96 :title title 97 :root-uri root-uri 98 :header header 99 :links links 100 :stylesheet stylesheet 101 :enable-rss enable-rss 102 :twitter-card twitter-card 103 :archive-date-list archive-date-list))) 104 105 (defun make-rss-generator (&key title link description image-url language 106 copyright managing-editor webmaster category) 107 (if (and title link description) 108 (lambda (posts) 109 (render-rss posts 110 :title title 111 :link link 112 :description description 113 :image-url image-url 114 :language language 115 :copyright copyright 116 :managing-editor managing-editor 117 :webmaster webmaster 118 :category category)) 119 (lambda (posts) 120 (declare (ignore posts))))) 121 122 (defun get-page-by-path (path pages) 123 (labels ((get-page-name (name page-list) 124 (find-if #'(lambda (page) (string= name (getf page :name))) 125 page-list))) 126 (car (last (loop for path-elem in path 127 for curr-page = pages then next-page 128 for page-list = (getf curr-page :children) 129 for next-page = (get-page-name path-elem page-list) 130 when (null next-page) return nil 131 collect next-page))))) 132 133 (defun get-page-id-by-path (path pages) 134 (getf (get-page-by-path path pages) :id)) 135 136 (defun get-path-to-page (id pages-table) 137 (reverse (loop for next-id = id then (getf page :parent) 138 until (zerop next-id) 139 for page = (gethash next-id pages-table) 140 when (null page) return nil 141 collect (getf page :name)))) 142 143 (defun year-month-of-entry (entry) 144 (if (not entry) 145 (error "Entry cannot be nil") 146 (let* ((entry-created-at (getf entry :created-at)) 147 (entry-year (timestamp-year entry-created-at)) 148 (entry-month (timestamp-month entry-created-at))) 149 (cons entry-year entry-month)))) 150 151 (defun year-month-of-latest-entry (entries) 152 (if (not entries) 153 (error "List of entries cannot be empty") 154 (year-month-of-entry (car entries)))) 155 156 (defun monthcdr (entries year month) 157 (if (not entries) 158 nil 159 (let* 160 ((year-month (year-month-of-latest-entry entries)) 161 (entry-year (car year-month)) 162 (entry-month (cdr year-month))) 163 (cond 164 ((< entry-year year) entries) 165 ((and (= entry-year year) (<= entry-month month)) entries) 166 (t (monthcdr (cdr entries) year month)))))) 167 168 (defun collect-entries-for-month (entries year month) 169 (if (not entries) 170 (cons nil entries) 171 (let* ((year-month (year-month-of-latest-entry entries)) 172 (entry-year (car year-month)) 173 (entry-month (cdr year-month))) 174 (if (or (/= entry-year year) (/= entry-month month)) 175 (cons nil entries) 176 (let ((collected (collect-entries-for-month 177 (cdr entries) year month))) 178 (cons (cons (car entries) (car collected)) (cdr collected))))))) 179 180 (defun get-archive-date-list (entries) 181 (labels 182 ((get-year-month-pair-for-entry (entry) 183 (let* ((created-at (getf entry :created-at)) 184 (year (timestamp-year created-at)) 185 (month (timestamp-month created-at))) 186 (cons year month))) 187 (year-month-pairs-equal-p (a b) 188 (and (= (car a) (car b)) (= (cdr a) (cdr b))))) 189 (remove-duplicates 190 (mapcar #'get-year-month-pair-for-entry entries) 191 :test #'year-month-pairs-equal-p))) 192 193 (defun gen-all-pages (pages &key prefix all-pages archive-date-list generator enable-rss twitter-card) 194 "Generate all pages in the tree rooted at PAGES. PREFIX may be supplied if this is a subtree, in which case ALL-PAGES should also be supplied so that the page nav can render correctly." 195 (labels ((with-paths (parent-path entries) 196 (mapcar #'(lambda (entry) 197 (cons entry 198 (append parent-path (cons (getf entry :name) nil)))) 199 entries)) 200 (gen-pages-recur (generated queue) 201 (if (= 0 (length queue)) 202 generated 203 (let* ((next-page (caar queue)) 204 (path (cdar queue)) 205 (next-page-content (gen-page next-page 206 path 207 (or all-pages pages) 208 :generator generator 209 :archive-date-list archive-date-list 210 :twitter-card twitter-card 211 :enable-rss enable-rss)) 212 (next-page-entry (list :page path nil next-page-content)) 213 (queue-rest (cdr queue)) 214 (queue-new (with-paths path (getf next-page :children)))) 215 (gen-pages-recur (append generated (cons next-page-entry nil)) 216 (append queue-rest queue-new)))))) 217 (gen-pages-recur nil (with-paths prefix (getf pages :children))))) 218 219 (defun gen-all (entries pages &key generator page-generator rss-generator twitter-card) 220 "Generate a list of all monthly pages and hierarchical pages as well as the index and RSS feed" 221 (labels 222 ((gen-all-years (entries pages archive-date-list generator enable-rss) 223 (let ((rest-entries (copy-list entries)) 224 (content '())) 225 (loop for year-month in archive-date-list do 226 (let ((month-content 227 (gen-month rest-entries 228 (car year-month) (cdr year-month) 229 pages 230 :twitter-card twitter-card 231 :enable-rss enable-rss 232 :archive-date-list archive-date-list 233 :generator generator))) 234 (setf rest-entries (cdr month-content)) 235 (setf content (cons (car month-content) content)))) 236 content))) 237 (let ((archive-date-list (get-archive-date-list entries)) 238 (rss-content (gen-rss-feed entries 239 :generator rss-generator))) 240 (append (list 241 (list :rss nil nil rss-content) 242 (list :index nil nil (gen-index entries pages 243 :twitter-card twitter-card 244 :enable-rss rss-content 245 :archive-date-list archive-date-list 246 :generator generator))) 247 (gen-all-pages pages 248 :archive-date-list archive-date-list 249 :generator page-generator 250 :twitter-card twitter-card 251 :enable-rss rss-content) 252 (gen-all-years entries pages 253 archive-date-list generator rss-content))))) 254 255 (defun top-ten (entries) 256 (if (>= (length entries) 10) 257 (subseq entries 0 10) 258 entries)) 259 260 (defun gen-rss-feed (entries &key generator) 261 "Generate the RSS feed content with the same posts as the index page" 262 (let ((index-entries (top-ten entries))) 263 (funcall (or generator (make-rss-generator)) 264 index-entries))) 265 266 (defun gen-index (entries pages &key generator archive-date-list enable-rss twitter-card) 267 "Generate the index (front page) with the latest ten posts" 268 (if (not entries) 269 (funcall (or generator (make-generator)) nil) 270 (let ((archive-date-list (or archive-date-list 271 (get-archive-date-list entries))) 272 (index-entries (top-ten entries))) 273 (funcall (or generator (make-generator)) 274 index-entries pages 275 :twitter-card twitter-card 276 :enable-rss enable-rss 277 :archive-date-list archive-date-list 278 :collapse-posts-p t)))) 279 280 (defun gen-month (entries year month pages &key generator archive-date-list enable-rss twitter-card) 281 "Generate a page with all posts for the given year and month" 282 (let ((archive-date-list (or archive-date-list 283 (get-archive-date-list entries)))) 284 (let* ((entries-at-month (monthcdr entries year month)) 285 (collected (collect-entries-for-month 286 entries-at-month year month)) 287 (month-entries (car collected)) 288 (rest-entries (cdr collected))) 289 (cons 290 (if month-entries 291 (list year month nil 292 (funcall (or generator (make-generator)) 293 month-entries pages 294 :year year 295 :month month 296 :twitter-card twitter-card 297 :enable-rss enable-rss 298 :archive-date-list archive-date-list 299 :collapse-posts-p t)) 300 nil) 301 rest-entries)))) 302 303 (defun gen-post (entry pages &key generator archive-date-list enable-rss twitter-card) 304 "Generate a single post page" 305 (funcall (or generator (make-generator)) 306 (list entry) pages 307 :twitter-card twitter-card 308 :enable-rss enable-rss 309 :archive-date-list archive-date-list)) 310 311 (defun gen-page (entry path pages &key generator archive-date-list enable-rss twitter-card) 312 "Generate a single page" 313 (funcall (or generator (make-page-generator)) 314 entry path pages 315 :twitter-card twitter-card 316 :enable-rss enable-rss 317 :archive-date-list archive-date-list))